Initial Commit
This commit is contained in:
Riley Schneider
1070
database/perl/vendor/lib/Test/Alien.pm
vendored
Normal file
1070
database/perl/vendor/lib/Test/Alien.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
907
database/perl/vendor/lib/Test/Alien/Build.pm
vendored
Normal file
907
database/perl/vendor/lib/Test/Alien/Build.pm
vendored
Normal file
@@ -0,0 +1,907 @@
|
||||
package Test::Alien::Build;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008004;
|
||||
use base qw( Exporter);
|
||||
use Path::Tiny qw( path );
|
||||
use Carp qw( croak );
|
||||
use Test2::API qw( context run_subtest );
|
||||
use Capture::Tiny qw( capture_merged );
|
||||
use Alien::Build::Util qw( _mirror );
|
||||
use List::Util 1.33 qw( any );
|
||||
use Alien::Build::Temp;
|
||||
|
||||
our @EXPORT = qw(
|
||||
alienfile
|
||||
alienfile_ok
|
||||
alienfile_skip_if_missing_prereqs
|
||||
alien_download_ok
|
||||
alien_extract_ok
|
||||
alien_build_ok
|
||||
alien_build_clean
|
||||
alien_clean_install
|
||||
alien_install_type_is
|
||||
alien_checkpoint_ok
|
||||
alien_resume_ok
|
||||
alien_subtest
|
||||
alien_rc
|
||||
);
|
||||
|
||||
# ABSTRACT: Tools for testing Alien::Build + alienfile
|
||||
our $VERSION = '2.38'; # VERSION
|
||||
|
||||
|
||||
my $build;
|
||||
my $build_alienfile;
|
||||
my $build_root;
|
||||
my $build_targ;
|
||||
|
||||
sub alienfile::targ
|
||||
{
|
||||
$build_targ;
|
||||
}
|
||||
|
||||
sub alienfile
|
||||
{
|
||||
my($package, $filename, $line) = caller;
|
||||
($package, $filename, $line) = caller(2) if $package eq __PACKAGE__;
|
||||
$filename = path($filename)->absolute;
|
||||
my %args = @_ == 0 ? (filename => 'alienfile') : @_ % 2 ? ( source => do { '# line '. $line . ' "' . path($filename)->absolute . qq("\n) . $_[0] }) : @_;
|
||||
|
||||
require alienfile;
|
||||
push @alienfile::EXPORT, 'targ' unless any { /^targ$/ } @alienfile::EXPORT;
|
||||
|
||||
my $temp = Alien::Build::Temp->newdir;
|
||||
my $get_temp_root = do{
|
||||
my $root; # may be undef;
|
||||
sub {
|
||||
$root ||= Path::Tiny->new($temp);
|
||||
|
||||
if(@_)
|
||||
{
|
||||
my $path = $root->child(@_);
|
||||
$path->mkpath;
|
||||
$path;
|
||||
}
|
||||
else
|
||||
{
|
||||
return $root;
|
||||
}
|
||||
};
|
||||
};
|
||||
|
||||
if($args{source})
|
||||
{
|
||||
my $file = $get_temp_root->()->child('alienfile');
|
||||
$file->spew_utf8($args{source});
|
||||
$args{filename} = $file->stringify;
|
||||
}
|
||||
else
|
||||
{
|
||||
unless(defined $args{filename})
|
||||
{
|
||||
croak "You must specify at least one of filename or source";
|
||||
}
|
||||
$args{filename} = path($args{filename})->absolute->stringify;
|
||||
}
|
||||
|
||||
$args{stage} ||= $get_temp_root->('stage')->stringify;
|
||||
$args{prefix} ||= $get_temp_root->('prefix')->stringify;
|
||||
$args{root} ||= $get_temp_root->('root')->stringify;
|
||||
|
||||
require Alien::Build;
|
||||
|
||||
_alienfile_clear();
|
||||
my $out = capture_merged {
|
||||
$build_targ = $args{targ};
|
||||
$build = Alien::Build->load($args{filename}, root => $args{root});
|
||||
$build->set_stage($args{stage});
|
||||
$build->set_prefix($args{prefix});
|
||||
};
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->note($out) if $out;
|
||||
$ctx->release;
|
||||
|
||||
$build_alienfile = $args{filename};
|
||||
$build_root = $temp;
|
||||
$build
|
||||
}
|
||||
|
||||
sub _alienfile_clear
|
||||
{
|
||||
eval { defined $build_root && -d $build_root && path($build_root)->remove_tree };
|
||||
undef $build;
|
||||
undef $build_alienfile;
|
||||
undef $build_root;
|
||||
undef $build_targ;
|
||||
}
|
||||
|
||||
|
||||
sub alienfile_ok
|
||||
{
|
||||
my $build;
|
||||
my $name;
|
||||
my $error;
|
||||
|
||||
if(@_ == 1 && ! defined $_[0])
|
||||
{
|
||||
$build = $_[0];
|
||||
$error = 'no alienfile given';
|
||||
$name = 'alienfile compiled';
|
||||
}
|
||||
elsif(@_ == 1 && eval { $_[0]->isa('Alien::Build') })
|
||||
{
|
||||
$build = $_[0];
|
||||
$name = 'alienfile compiled';
|
||||
}
|
||||
else
|
||||
{
|
||||
$build = eval { alienfile(@_) };
|
||||
$error = $@;
|
||||
$name = 'alienfile compiles';
|
||||
}
|
||||
|
||||
my $ok = !! $build;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag("error: $error") if $error;
|
||||
$ctx->release;
|
||||
|
||||
$build;
|
||||
}
|
||||
|
||||
|
||||
sub alienfile_skip_if_missing_prereqs
|
||||
{
|
||||
my($phase) = @_;
|
||||
|
||||
if($build)
|
||||
{
|
||||
eval { $build->load_requires('configure', 1) };
|
||||
if(my $error = $@)
|
||||
{
|
||||
my $reason = "Missing configure prereq";
|
||||
if($error =~ /Required (.*) (.*),/)
|
||||
{
|
||||
$reason .= ": $1 $2";
|
||||
}
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $reason);
|
||||
$ctx->release;
|
||||
return;
|
||||
}
|
||||
$phase ||= $build->install_type;
|
||||
eval { $build->load_requires($phase, 1) };
|
||||
if(my $error = $@)
|
||||
{
|
||||
my $reason = "Missing $phase prereq";
|
||||
if($error =~ /Required (.*) (.*),/)
|
||||
{
|
||||
$reason .= ": $1 $2";
|
||||
}
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $reason);
|
||||
$ctx->release;
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub alien_install_type_is
|
||||
{
|
||||
my($type, $name) = @_;
|
||||
|
||||
croak "invalid install type" unless defined $type && $type =~ /^(system|share)$/;
|
||||
$name ||= "alien install type is $type";
|
||||
|
||||
my $ok = 0;
|
||||
my @diag;
|
||||
|
||||
if($build)
|
||||
{
|
||||
my($out, $actual) = capture_merged {
|
||||
$build->load_requires('configure');
|
||||
$build->install_type;
|
||||
};
|
||||
if($type eq $actual)
|
||||
{
|
||||
$ok = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
push @diag, "expected install type of $type, but got $actual";
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
push @diag, 'no alienfile'
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->release;
|
||||
|
||||
$ok;
|
||||
}
|
||||
|
||||
|
||||
sub alien_download_ok
|
||||
{
|
||||
my($name) = @_;
|
||||
|
||||
$name ||= 'alien download';
|
||||
|
||||
my $ok;
|
||||
my $file;
|
||||
my @diag;
|
||||
my @note;
|
||||
|
||||
if($build)
|
||||
{
|
||||
my($out, $error) = capture_merged {
|
||||
eval {
|
||||
$build->load_requires('configure');
|
||||
$build->load_requires($build->install_type);
|
||||
$build->download;
|
||||
};
|
||||
$@;
|
||||
};
|
||||
if($error)
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, $out if defined $out;
|
||||
push @diag, "extract threw exception: $error";
|
||||
}
|
||||
else
|
||||
{
|
||||
$file = $build->install_prop->{download};
|
||||
if(-d $file || -f $file)
|
||||
{
|
||||
$ok = 1;
|
||||
push @note, $out if defined $out;
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, $out if defined $out;
|
||||
push @diag, 'no file or directory';
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, 'no alienfile';
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->note($_) for @note;
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->release;
|
||||
|
||||
$file;
|
||||
}
|
||||
|
||||
|
||||
sub alien_extract_ok
|
||||
{
|
||||
my($archive, $name) = @_;
|
||||
|
||||
$name ||= $archive ? "alien extraction of $archive" : 'alien extraction';
|
||||
my $ok;
|
||||
my $dir;
|
||||
my @diag;
|
||||
|
||||
if($build)
|
||||
{
|
||||
my($out, $error);
|
||||
($out, $dir, $error) = capture_merged {
|
||||
my $dir = eval {
|
||||
$build->load_requires('configure');
|
||||
$build->load_requires($build->install_type);
|
||||
$build->download;
|
||||
$build->extract($archive);
|
||||
};
|
||||
($dir, $@);
|
||||
};
|
||||
if($error)
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, $out if defined $out;
|
||||
push @diag, "extract threw exception: $error";
|
||||
}
|
||||
else
|
||||
{
|
||||
if(-d $dir)
|
||||
{
|
||||
$ok = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, 'no directory';
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, 'no alienfile';
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->release;
|
||||
|
||||
$dir;
|
||||
}
|
||||
|
||||
|
||||
my $count = 1;
|
||||
|
||||
sub alien_build_ok
|
||||
{
|
||||
my $opt = defined $_[0] && ref($_[0]) eq 'HASH'
|
||||
? shift : { class => 'Alien::Base' };
|
||||
|
||||
my($name) = @_;
|
||||
|
||||
$name ||= 'alien builds okay';
|
||||
my $ok;
|
||||
my @diag;
|
||||
my @note;
|
||||
my $alien;
|
||||
|
||||
if($build)
|
||||
{
|
||||
my($out,$error) = capture_merged {
|
||||
eval {
|
||||
$build->load_requires('configure');
|
||||
$build->load_requires($build->install_type);
|
||||
$build->download;
|
||||
$build->build;
|
||||
};
|
||||
$@;
|
||||
};
|
||||
if($error)
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, $out if defined $out;
|
||||
push @diag, "build threw exception: $error";
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 1;
|
||||
|
||||
push @note, $out if defined $out;
|
||||
|
||||
require Alien::Base;
|
||||
|
||||
my $prefix = $build->runtime_prop->{prefix};
|
||||
my $stage = $build->install_prop->{stage};
|
||||
my %prop = %{ $build->runtime_prop };
|
||||
|
||||
$prop{distdir} = $prefix;
|
||||
|
||||
_mirror $stage, $prefix;
|
||||
|
||||
my $dist_dir = sub {
|
||||
$prefix;
|
||||
};
|
||||
|
||||
my $runtime_prop = sub {
|
||||
\%prop;
|
||||
};
|
||||
|
||||
$alien = sprintf 'Test::Alien::Build::Faux%04d', $count++;
|
||||
{
|
||||
no strict 'refs';
|
||||
@{ "${alien}::ISA" } = $opt->{class};
|
||||
*{ "${alien}::dist_dir" } = $dist_dir;
|
||||
*{ "${alien}::runtime_prop" } = $runtime_prop;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, 'no alienfile';
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->note($_) for @note;
|
||||
$ctx->release;
|
||||
|
||||
$alien;
|
||||
}
|
||||
|
||||
|
||||
sub alien_build_clean
|
||||
{
|
||||
my $ctx = context();
|
||||
if($build_root)
|
||||
{
|
||||
foreach my $child (path($build_root)->children)
|
||||
{
|
||||
next if $child->basename eq 'prefix';
|
||||
$ctx->note("clean: rm: $child");
|
||||
$child->remove_tree;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$ctx->note("no build to clean");
|
||||
}
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
|
||||
sub alien_clean_install
|
||||
{
|
||||
my($name) = @_;
|
||||
|
||||
$name ||= "run clean_install";
|
||||
|
||||
my $ok;
|
||||
my @diag;
|
||||
my @note;
|
||||
|
||||
if($build)
|
||||
{
|
||||
my($out,$error) = capture_merged {
|
||||
eval {
|
||||
$build->clean_install;
|
||||
};
|
||||
$@;
|
||||
};
|
||||
if($error)
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, $out if defined $out && $out ne '';
|
||||
push @diag, "build threw exception: $error";
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 1;
|
||||
push @note, $out if defined $out && $out ne '';
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 0;
|
||||
push @diag, 'no alienfile';
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->note($_) for @note;
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
|
||||
sub alien_checkpoint_ok
|
||||
{
|
||||
my($name) = @_;
|
||||
|
||||
$name ||= "alien checkpoint ok";
|
||||
my $ok;
|
||||
my @diag;
|
||||
|
||||
if($build)
|
||||
{
|
||||
eval { $build->checkpoint };
|
||||
if($@)
|
||||
{
|
||||
push @diag, "error in checkpoint: $@";
|
||||
$ok = 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 1;
|
||||
}
|
||||
undef $build;
|
||||
}
|
||||
else
|
||||
{
|
||||
push @diag, "no build to checkpoint";
|
||||
$ok = 0;
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->release;
|
||||
|
||||
$ok;
|
||||
}
|
||||
|
||||
|
||||
sub alien_resume_ok
|
||||
{
|
||||
my($name) = @_;
|
||||
|
||||
$name ||= "alien resume ok";
|
||||
my $ok;
|
||||
my @diag;
|
||||
|
||||
if($build_alienfile && $build_root && !defined $build)
|
||||
{
|
||||
$build = eval { Alien::Build->resume($build_alienfile, "$build_root/root") };
|
||||
if($@)
|
||||
{
|
||||
push @diag, "error in resume: $@";
|
||||
$ok = 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
$ok = 1;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if($build)
|
||||
{
|
||||
push @diag, "build has not been checkpointed";
|
||||
}
|
||||
else
|
||||
{
|
||||
push @diag, "no build to resume";
|
||||
}
|
||||
$ok = 0;
|
||||
}
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $name);
|
||||
$ctx->diag($_) for @diag;
|
||||
$ctx->release;
|
||||
|
||||
($ok && $build) || $ok;
|
||||
}
|
||||
|
||||
|
||||
my $alien_rc_root;
|
||||
|
||||
sub alien_rc
|
||||
{
|
||||
my($code) = @_;
|
||||
|
||||
croak "passed in undef rc" unless defined $code;
|
||||
croak "looks like you have already defined a rc.pl file" if $ENV{ALIEN_BUILD_RC} ne '-';
|
||||
|
||||
my(undef, $filename, $line) = caller;
|
||||
my $code2 = "use strict; use warnings;\n" .
|
||||
'# line ' . $line . ' "' . path($filename)->absolute . "\n$code";
|
||||
|
||||
$alien_rc_root ||= Alien::Build::Temp->newdir;
|
||||
|
||||
my $rc = path($alien_rc_root)->child('rc.pl');
|
||||
$rc->spew_utf8($code2);
|
||||
$ENV{ALIEN_BUILD_RC} = "$rc";
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub alien_subtest
|
||||
{
|
||||
my($name, $code, @args) = @_;
|
||||
|
||||
_alienfile_clear;
|
||||
|
||||
my $ctx = context();
|
||||
my $pass = run_subtest($name, $code, { buffered => 1 }, @args);
|
||||
$ctx->release;
|
||||
|
||||
_alienfile_clear;
|
||||
|
||||
$pass;
|
||||
}
|
||||
|
||||
delete $ENV{$_} for qw( ALIEN_BUILD_LOG ALIEN_BUILD_PRELOAD ALIEN_BUILD_POSTLOAD ALIEN_INSTALL_TYPE PKG_CONFIG_PATH ALIEN_BUILD_PKG_CONFIG );
|
||||
$ENV{ALIEN_BUILD_RC} = '-';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Alien::Build - Tools for testing Alien::Build + alienfile
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.38
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test::Alien::Build;
|
||||
|
||||
# returns an instance of Alien::Build.
|
||||
my $build = alienfile_ok q{
|
||||
use alienfile;
|
||||
|
||||
plugin 'My::Plugin' => (
|
||||
foo => 1,
|
||||
bar => 'string',
|
||||
...
|
||||
);
|
||||
};
|
||||
|
||||
alien_build_ok 'builds okay.';
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some tools for testing L<Alien::Build> and L<alienfile>. Outside of L<Alien::Build>
|
||||
core development, It is probably most useful for L<Alien::Build::Plugin> developers.
|
||||
|
||||
This module also unsets a number of L<Alien::Build> specific environment variables, in order to make tests
|
||||
reproducible even when overrides are set in different environments. So if you want to test those variables in
|
||||
various states you should explicitly set them in your test script. These variables are unset if they defined:
|
||||
C<ALIEN_BUILD_PRELOAD> C<ALIEN_BUILD_POSTLOAD> C<ALIEN_INSTALL_TYPE>.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 alienfile
|
||||
|
||||
my $build = alienfile;
|
||||
my $build = alienfile q{ use alienfile ... };
|
||||
my $build = alienfile filename => 'alienfile';
|
||||
|
||||
Create a Alien::Build instance from the given L<alienfile>. The first two forms are abbreviations.
|
||||
|
||||
my $build = alienfile;
|
||||
# is the same as
|
||||
my $build = alienfile filename => 'alienfile';
|
||||
|
||||
and
|
||||
|
||||
my $build = alienfile q{ use alienfile ... };
|
||||
# is the same as
|
||||
my $build = alienfile source => q{ use alienfile ... };
|
||||
|
||||
Except for the second abbreviated form sets the line number before feeding the source into L<Alien::Build>
|
||||
so that you will get diagnostics with the correct line numbers.
|
||||
|
||||
=over 4
|
||||
|
||||
=item source
|
||||
|
||||
The source for the alienfile as a string. You must specify one of C<source> or C<filename>.
|
||||
|
||||
=item filename
|
||||
|
||||
The filename for the alienfile. You must specify one of C<source> or C<filename>.
|
||||
|
||||
=item root
|
||||
|
||||
The build root.
|
||||
|
||||
=item stage
|
||||
|
||||
The staging area for the build.
|
||||
|
||||
=item prefix
|
||||
|
||||
The install prefix for the build.
|
||||
|
||||
=back
|
||||
|
||||
=head2 alienfile_ok
|
||||
|
||||
my $build = alienfile_ok;
|
||||
my $build = alienfile_ok q{ use alienfile ... };
|
||||
my $build = alienfile_ok filename => 'alienfile';
|
||||
my $build = alienfile_ok $build;
|
||||
|
||||
Same as C<alienfile> above, except that it runs as a test, and will not throw an exception
|
||||
on failure (it will return undef instead).
|
||||
|
||||
[version 1.49]
|
||||
|
||||
As of version 1.49 you can also pass in an already formed instance of L<Alien::Build>. This
|
||||
allows you to do something like this:
|
||||
|
||||
subtest 'a subtest' => sub {
|
||||
my $build = alienfile q{ use alienfile; ... };
|
||||
alienfile_skip_if_missing_prereqs; # skip if alienfile prereqs are missing
|
||||
alienfile_ok $build; # delayed pass/fail for the compile of alienfile
|
||||
};
|
||||
|
||||
=head2 alienfile_skip_if_missing_prereqs
|
||||
|
||||
alienfile_skip_if_missing_prereqs;
|
||||
alienfile_skip_if_missing_prereqs $phase;
|
||||
|
||||
Skips the test or subtest if the prereqs for the alienfile are missing.
|
||||
If C<$phase> is not given, then either C<share> or C<system> will be
|
||||
detected.
|
||||
|
||||
=head2 alien_install_type_is
|
||||
|
||||
alien_install_type_is $type;
|
||||
alien_install_type_is $type, $name;
|
||||
|
||||
Simple test to see if the install type is what you expect.
|
||||
C<$type> should be one of C<system> or C<share>.
|
||||
|
||||
=head2 alien_download_ok
|
||||
|
||||
my $file = alien_download_ok;
|
||||
my $file = alien_download_ok $name;
|
||||
|
||||
Makes a download attempt and test that a file or directory results. Returns
|
||||
the file or directory if successful. Returns C<undef> otherwise.
|
||||
|
||||
=head2 alien_extract_ok
|
||||
|
||||
my $dir = alien_extract_ok;
|
||||
my $dir = alien_extract_ok $archive;
|
||||
my $dir = alien_extract_ok $archive, $name;
|
||||
my $dir = alien_extract_ok undef, $name;
|
||||
|
||||
Makes an extraction attempt and test that a directory results. Returns
|
||||
the directory if successful. Returns C<undef> otherwise.
|
||||
|
||||
=head2 alien_build_ok
|
||||
|
||||
my $alien = alien_build_ok;
|
||||
my $alien = alien_build_ok $name;
|
||||
my $alien = alien_build_ok { class => $class };
|
||||
my $alien = alien_build_ok { class => $class }, $name;
|
||||
|
||||
Runs the download and build stages. Passes if the build succeeds. Returns an instance
|
||||
of L<Alien::Base> which can be passed into C<alien_ok> from L<Test::Alien>. Returns
|
||||
C<undef> if the test fails.
|
||||
|
||||
Options
|
||||
|
||||
=over 4
|
||||
|
||||
=item class
|
||||
|
||||
The base class to use for your alien. This is L<Alien::Base> by default. Should
|
||||
be a subclass of L<Alien::Base>, or at least adhere to its API.
|
||||
|
||||
=back
|
||||
|
||||
=head2 alien_build_clean
|
||||
|
||||
alien_build_clean;
|
||||
|
||||
Removes all files with the current build, except for the runtime prefix.
|
||||
This helps test that the final install won't depend on the build files.
|
||||
|
||||
=head2 alien_clean_install
|
||||
|
||||
alien_clean_install;
|
||||
|
||||
Runs C<$build-E<gt>clean_install>, and verifies it did not crash.
|
||||
|
||||
=head2 alien_checkpoint_ok
|
||||
|
||||
alien_checkpoint_ok;
|
||||
alien_checkpoint_ok $test_name;
|
||||
|
||||
Test the checkpoint of a build.
|
||||
|
||||
=head2 alien_resume_ok
|
||||
|
||||
alien_resume_ok;
|
||||
alien_resume_ok $test_name;
|
||||
|
||||
Test a resume a checkpointed build.
|
||||
|
||||
=head2 alien_rc
|
||||
|
||||
alien_rc $code;
|
||||
|
||||
Creates C<rc.pl> file in a temp directory and sets ALIEN_BUILD_RC. Useful for testing
|
||||
plugins that should be called from C<~/.alienbuild/rc.pl>. Note that because of the
|
||||
nature of how the C<~/.alienbuild/rc.pl> file works, you can only use this once!
|
||||
|
||||
=head2 alien_subtest
|
||||
|
||||
alien_subtest $test_name => sub {
|
||||
...
|
||||
};
|
||||
|
||||
Clear the build object and clear the build object before and after the subtest.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Alien>
|
||||
|
||||
=item L<alienfile>
|
||||
|
||||
=item L<Alien::Build>
|
||||
|
||||
=item L<Test::Alien>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Diab Jerius (DJERIUS)
|
||||
|
||||
Roy Storey (KIWIROY)
|
||||
|
||||
Ilya Pavlov
|
||||
|
||||
David Mertens (run4flat)
|
||||
|
||||
Mark Nunberg (mordy, mnunberg)
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
|
||||
Brian Wightman (MidLifeXis)
|
||||
|
||||
Zaki Mughal (zmughal)
|
||||
|
||||
mohawk (mohawk2, ETJ)
|
||||
|
||||
Vikas N Kumar (vikasnkumar)
|
||||
|
||||
Flavio Poletti (polettix)
|
||||
|
||||
Salvador Fandiño (salva)
|
||||
|
||||
Gianni Ceccarelli (dakkar)
|
||||
|
||||
Pavel Shaydo (zwon, trinitum)
|
||||
|
||||
Kang-min Liu (劉康民, gugod)
|
||||
|
||||
Nicholas Shipp (nshp)
|
||||
|
||||
Juan Julián Merelo Guervós (JJ)
|
||||
|
||||
Joel Berger (JBERGER)
|
||||
|
||||
Petr Pisar (ppisar)
|
||||
|
||||
Lance Wicks (LANCEW)
|
||||
|
||||
Ahmad Fatoum (a3f, ATHREEF)
|
||||
|
||||
José Joaquín Atria (JJATRIA)
|
||||
|
||||
Duke Leto (LETO)
|
||||
|
||||
Shoichi Kaji (SKAJI)
|
||||
|
||||
Shawn Laffan (SLAFFAN)
|
||||
|
||||
Paul Evans (leonerd, PEVANS)
|
||||
|
||||
Håkon Hægland (hakonhagland, HAKONH)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011-2020 by Graham Ollis.
|
||||
|
||||
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
|
||||
128
database/perl/vendor/lib/Test/Alien/CanCompile.pm
vendored
Normal file
128
database/perl/vendor/lib/Test/Alien/CanCompile.pm
vendored
Normal file
@@ -0,0 +1,128 @@
|
||||
package Test::Alien::CanCompile;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008004;
|
||||
use Test2::API qw( context );
|
||||
|
||||
# ABSTRACT: Skip a test file unless a C compiler is available
|
||||
our $VERSION = '2.38'; # VERSION
|
||||
|
||||
|
||||
sub skip
|
||||
{
|
||||
require ExtUtils::CBuilder;
|
||||
ExtUtils::CBuilder->new->have_compiler ? undef : 'This test requires a compiler.';
|
||||
}
|
||||
|
||||
sub import
|
||||
{
|
||||
my $skip = __PACKAGE__->skip;
|
||||
return unless defined $skip;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $skip);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Alien::CanCompile - Skip a test file unless a C compiler is available
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.38
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Alien::CanCompile;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is just a L<Test2> plugin that requires that a compiler
|
||||
be available. Otherwise the test will be skipped.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::Alien>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Diab Jerius (DJERIUS)
|
||||
|
||||
Roy Storey (KIWIROY)
|
||||
|
||||
Ilya Pavlov
|
||||
|
||||
David Mertens (run4flat)
|
||||
|
||||
Mark Nunberg (mordy, mnunberg)
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
|
||||
Brian Wightman (MidLifeXis)
|
||||
|
||||
Zaki Mughal (zmughal)
|
||||
|
||||
mohawk (mohawk2, ETJ)
|
||||
|
||||
Vikas N Kumar (vikasnkumar)
|
||||
|
||||
Flavio Poletti (polettix)
|
||||
|
||||
Salvador Fandiño (salva)
|
||||
|
||||
Gianni Ceccarelli (dakkar)
|
||||
|
||||
Pavel Shaydo (zwon, trinitum)
|
||||
|
||||
Kang-min Liu (劉康民, gugod)
|
||||
|
||||
Nicholas Shipp (nshp)
|
||||
|
||||
Juan Julián Merelo Guervós (JJ)
|
||||
|
||||
Joel Berger (JBERGER)
|
||||
|
||||
Petr Pisar (ppisar)
|
||||
|
||||
Lance Wicks (LANCEW)
|
||||
|
||||
Ahmad Fatoum (a3f, ATHREEF)
|
||||
|
||||
José Joaquín Atria (JJATRIA)
|
||||
|
||||
Duke Leto (LETO)
|
||||
|
||||
Shoichi Kaji (SKAJI)
|
||||
|
||||
Shawn Laffan (SLAFFAN)
|
||||
|
||||
Paul Evans (leonerd, PEVANS)
|
||||
|
||||
Håkon Hægland (hakonhagland, HAKONH)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011-2020 by Graham Ollis.
|
||||
|
||||
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
|
||||
129
database/perl/vendor/lib/Test/Alien/CanPlatypus.pm
vendored
Normal file
129
database/perl/vendor/lib/Test/Alien/CanPlatypus.pm
vendored
Normal file
@@ -0,0 +1,129 @@
|
||||
package Test::Alien::CanPlatypus;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008004;
|
||||
use Test2::API qw( context );
|
||||
|
||||
# ABSTRACT: Skip a test file unless FFI::Platypus is available
|
||||
our $VERSION = '2.38'; # VERSION
|
||||
|
||||
|
||||
sub skip
|
||||
{
|
||||
eval { require FFI::Platypus; 1 } ? undef : 'This test requires FFI::Platypus.';
|
||||
}
|
||||
|
||||
sub import
|
||||
{
|
||||
my $skip = __PACKAGE__->skip;
|
||||
return unless defined $skip;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $skip);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Alien::CanPlatypus - Skip a test file unless FFI::Platypus is available
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.38
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Alien::CanPlatypus;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is just a L<Test2> plugin that requires that L<FFI::Platypus>
|
||||
be available. Otherwise the test will be skipped.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::Alien>
|
||||
|
||||
=item L<FFI::Platypus>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Diab Jerius (DJERIUS)
|
||||
|
||||
Roy Storey (KIWIROY)
|
||||
|
||||
Ilya Pavlov
|
||||
|
||||
David Mertens (run4flat)
|
||||
|
||||
Mark Nunberg (mordy, mnunberg)
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
|
||||
Brian Wightman (MidLifeXis)
|
||||
|
||||
Zaki Mughal (zmughal)
|
||||
|
||||
mohawk (mohawk2, ETJ)
|
||||
|
||||
Vikas N Kumar (vikasnkumar)
|
||||
|
||||
Flavio Poletti (polettix)
|
||||
|
||||
Salvador Fandiño (salva)
|
||||
|
||||
Gianni Ceccarelli (dakkar)
|
||||
|
||||
Pavel Shaydo (zwon, trinitum)
|
||||
|
||||
Kang-min Liu (劉康民, gugod)
|
||||
|
||||
Nicholas Shipp (nshp)
|
||||
|
||||
Juan Julián Merelo Guervós (JJ)
|
||||
|
||||
Joel Berger (JBERGER)
|
||||
|
||||
Petr Pisar (ppisar)
|
||||
|
||||
Lance Wicks (LANCEW)
|
||||
|
||||
Ahmad Fatoum (a3f, ATHREEF)
|
||||
|
||||
José Joaquín Atria (JJATRIA)
|
||||
|
||||
Duke Leto (LETO)
|
||||
|
||||
Shoichi Kaji (SKAJI)
|
||||
|
||||
Shawn Laffan (SLAFFAN)
|
||||
|
||||
Paul Evans (leonerd, PEVANS)
|
||||
|
||||
Håkon Hægland (hakonhagland, HAKONH)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011-2020 by Graham Ollis.
|
||||
|
||||
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
|
||||
170
database/perl/vendor/lib/Test/Alien/Diag.pm
vendored
Normal file
170
database/perl/vendor/lib/Test/Alien/Diag.pm
vendored
Normal file
@@ -0,0 +1,170 @@
|
||||
package Test::Alien::Diag;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008004;
|
||||
use Test2::API qw( context );
|
||||
use base qw( Exporter );
|
||||
|
||||
our @EXPORT = qw( alien_diag );
|
||||
our @EXPORT_OK = @EXPORT;
|
||||
|
||||
# ABSTRACT: Print out standard diagnostic for Aliens in the test step.
|
||||
our $VERSION = '2.38'; # VERSION
|
||||
|
||||
|
||||
sub alien_diag ($@)
|
||||
{
|
||||
my $ctx = context();
|
||||
|
||||
my $max = 0;
|
||||
foreach my $alien (@_)
|
||||
{
|
||||
foreach my $name (qw( cflags cflags_static libs libs_static version install_type dynamic_libs bin_dir ))
|
||||
{
|
||||
my $str = "$alien->$name";
|
||||
if(length($str) > $max)
|
||||
{
|
||||
$max = length($str);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
$ctx->diag('');
|
||||
foreach my $alien (@_) {
|
||||
$ctx->diag('') for 1..2;
|
||||
|
||||
my $found = 0;
|
||||
|
||||
foreach my $name (qw( cflags cflags_static libs libs_static version install_type ))
|
||||
{
|
||||
if(eval { $alien->can($name) })
|
||||
{
|
||||
$found++;
|
||||
$ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $alien->$name);
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $name (qw( dynamic_libs bin_dir ))
|
||||
{
|
||||
if(eval { $alien->can($name) })
|
||||
{
|
||||
$found++;
|
||||
my @list = eval { $alien->$name };
|
||||
next if $@;
|
||||
$ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $_) for @list;
|
||||
}
|
||||
}
|
||||
|
||||
$ctx->diag("no diagnostics found for $alien") unless $found;
|
||||
|
||||
$ctx->diag('') for 1..2;
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Alien::Diag - Print out standard diagnostic for Aliens in the test step.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.38
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test::Alien::Diag qw( alien_diag );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides an C<alien_diag> method that prints out diagnostics useful for
|
||||
cpantesters for other bug reports that gives a quick summary of the important settings
|
||||
like C<clfags> and C<libs>.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 alien_diag
|
||||
|
||||
alien_diag $alien;
|
||||
|
||||
prints out diagnostics.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Diab Jerius (DJERIUS)
|
||||
|
||||
Roy Storey (KIWIROY)
|
||||
|
||||
Ilya Pavlov
|
||||
|
||||
David Mertens (run4flat)
|
||||
|
||||
Mark Nunberg (mordy, mnunberg)
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
|
||||
Brian Wightman (MidLifeXis)
|
||||
|
||||
Zaki Mughal (zmughal)
|
||||
|
||||
mohawk (mohawk2, ETJ)
|
||||
|
||||
Vikas N Kumar (vikasnkumar)
|
||||
|
||||
Flavio Poletti (polettix)
|
||||
|
||||
Salvador Fandiño (salva)
|
||||
|
||||
Gianni Ceccarelli (dakkar)
|
||||
|
||||
Pavel Shaydo (zwon, trinitum)
|
||||
|
||||
Kang-min Liu (劉康民, gugod)
|
||||
|
||||
Nicholas Shipp (nshp)
|
||||
|
||||
Juan Julián Merelo Guervós (JJ)
|
||||
|
||||
Joel Berger (JBERGER)
|
||||
|
||||
Petr Pisar (ppisar)
|
||||
|
||||
Lance Wicks (LANCEW)
|
||||
|
||||
Ahmad Fatoum (a3f, ATHREEF)
|
||||
|
||||
José Joaquín Atria (JJATRIA)
|
||||
|
||||
Duke Leto (LETO)
|
||||
|
||||
Shoichi Kaji (SKAJI)
|
||||
|
||||
Shawn Laffan (SLAFFAN)
|
||||
|
||||
Paul Evans (leonerd, PEVANS)
|
||||
|
||||
Håkon Hægland (hakonhagland, HAKONH)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011-2020 by Graham Ollis.
|
||||
|
||||
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
|
||||
361
database/perl/vendor/lib/Test/Alien/Run.pm
vendored
Normal file
361
database/perl/vendor/lib/Test/Alien/Run.pm
vendored
Normal file
@@ -0,0 +1,361 @@
|
||||
package Test::Alien::Run;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008004;
|
||||
use Test2::API qw( context );
|
||||
|
||||
# ABSTRACT: Run object
|
||||
our $VERSION = '2.38'; # VERSION
|
||||
|
||||
|
||||
sub out { shift->{out} }
|
||||
sub err { shift->{err} }
|
||||
sub exit { shift->{exit} }
|
||||
sub signal { shift->{sig} }
|
||||
|
||||
|
||||
sub success
|
||||
{
|
||||
my($self, $message) = @_;
|
||||
$message ||= 'command succeeded';
|
||||
my $ok = $self->exit == 0 && $self->signal == 0;
|
||||
$ok = 0 if $self->{fail};
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $message);
|
||||
unless($ok)
|
||||
{
|
||||
$ctx->diag(" command exited with @{[ $self->exit ]}") if $self->exit;
|
||||
$ctx->diag(" command killed with @{[ $self->signal ]}") if $self->signal;
|
||||
$ctx->diag(" @{[ $self->{fail} ]}") if $self->{fail};
|
||||
}
|
||||
$ctx->release;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub exit_is
|
||||
{
|
||||
my($self, $exit, $message) = @_;
|
||||
|
||||
$message ||= "command exited with value $exit";
|
||||
my $ok = $self->exit == $exit;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $message);
|
||||
$ctx->diag(" actual exit value was: @{[ $self->exit ]}") unless $ok;
|
||||
$ctx->release;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub exit_isnt
|
||||
{
|
||||
my($self, $exit, $message) = @_;
|
||||
|
||||
$message ||= "command exited with value not $exit";
|
||||
my $ok = $self->exit != $exit;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $message);
|
||||
$ctx->diag(" actual exit value was: @{[ $self->exit ]}") unless $ok;
|
||||
$ctx->release;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub _like
|
||||
{
|
||||
my($self, $regex, $source, $not, $message) = @_;
|
||||
|
||||
my $ok = $self->{$source} =~ $regex;
|
||||
$ok = !$ok if $not;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok($ok, $message);
|
||||
unless($ok)
|
||||
{
|
||||
$ctx->diag(" $source:");
|
||||
$ctx->diag(" $_") for split /\r?\n/, $self->{$source};
|
||||
$ctx->diag($not ? ' matches:' : ' does not match:');
|
||||
$ctx->diag(" $regex");
|
||||
}
|
||||
$ctx->release;
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
sub out_like
|
||||
{
|
||||
my($self, $regex, $message) = @_;
|
||||
$message ||= "output matches $regex";
|
||||
$self->_like($regex, 'out', 0, $message);
|
||||
}
|
||||
|
||||
|
||||
sub out_unlike
|
||||
{
|
||||
my($self, $regex, $message) = @_;
|
||||
$message ||= "output does not match $regex";
|
||||
$self->_like($regex, 'out', 1, $message);
|
||||
}
|
||||
|
||||
|
||||
sub err_like
|
||||
{
|
||||
my($self, $regex, $message) = @_;
|
||||
$message ||= "standard error matches $regex";
|
||||
$self->_like($regex, 'err', 0, $message);
|
||||
}
|
||||
|
||||
|
||||
sub err_unlike
|
||||
{
|
||||
my($self, $regex, $message) = @_;
|
||||
$message ||= "standard error does not match $regex";
|
||||
$self->_like($regex, 'err', 1, $message);
|
||||
}
|
||||
|
||||
|
||||
sub note
|
||||
{
|
||||
my($self) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->note("[cmd]");
|
||||
$ctx->note(" @{$self->{cmd}}");
|
||||
if($self->out ne '')
|
||||
{
|
||||
$ctx->note("[out]");
|
||||
$ctx->note(" $_") for split /\r?\n/, $self->out;
|
||||
}
|
||||
if($self->err ne '')
|
||||
{
|
||||
$ctx->note("[err]");
|
||||
$ctx->note(" $_") for split /\r?\n/, $self->err;
|
||||
}
|
||||
$ctx->release;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub diag
|
||||
{
|
||||
my($self) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->diag("[cmd]");
|
||||
$ctx->diag(" @{$self->{cmd}}");
|
||||
if($self->out ne '')
|
||||
{
|
||||
$ctx->diag("[out]");
|
||||
$ctx->diag(" $_") for split /\r?\n/, $self->out;
|
||||
}
|
||||
if($self->err ne '')
|
||||
{
|
||||
$ctx->diag("[err]");
|
||||
$ctx->diag(" $_") for split /\r?\n/, $self->err;
|
||||
}
|
||||
$ctx->release;
|
||||
$self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Alien::Run - Run object
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.38
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test::Alien;
|
||||
|
||||
run_ok([ $^X, -e => 'print "some output"; exit 22'])
|
||||
->exit_is(22)
|
||||
->out_like(qr{some});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class stores information about a process run as performed by
|
||||
L<Test::Alien#run_ok>. That function is the I<ONLY> way to create
|
||||
an instance of this class.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 out
|
||||
|
||||
my $str = $run->out;
|
||||
|
||||
The standard output from the run.
|
||||
|
||||
=head2 err
|
||||
|
||||
my $str = $run->err;
|
||||
|
||||
The standard error from the run.
|
||||
|
||||
=head2 exit
|
||||
|
||||
my $int = $run->exit;
|
||||
|
||||
The exit value of the run.
|
||||
|
||||
=head2 signal
|
||||
|
||||
my $int = $run->signal;
|
||||
|
||||
The signal that killed the run, or zero if the process was terminated normally.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods return the run object itself, so they can be chained,
|
||||
as in the synopsis above.
|
||||
|
||||
=head2 success
|
||||
|
||||
$run->success;
|
||||
$run->success($message);
|
||||
|
||||
Passes if the process terminated normally with an exit value of 0.
|
||||
|
||||
=head2 exit_is
|
||||
|
||||
$run->exit_is($exit);
|
||||
$run->exit_is($exit, $message);
|
||||
|
||||
Passes if the process terminated with the given exit value.
|
||||
|
||||
=head2 exit_isnt
|
||||
|
||||
$run->exit_isnt($exit);
|
||||
$run->exit_isnt($exit, $message);
|
||||
|
||||
Passes if the process terminated with an exit value of anything
|
||||
but the given value.
|
||||
|
||||
=head2 out_like
|
||||
|
||||
$run->out_like($regex);
|
||||
$run->out_like($regex, $message);
|
||||
|
||||
Passes if the output of the run matches the given pattern.
|
||||
|
||||
=head2 out_unlike
|
||||
|
||||
$run->out_unlike($regex);
|
||||
$run->out_unlike($regex, $message);
|
||||
|
||||
Passes if the output of the run does not match the given pattern.
|
||||
|
||||
=head2 err_like
|
||||
|
||||
$run->err_like($regex);
|
||||
$run->err_like($regex, $message);
|
||||
|
||||
Passes if the standard error of the run matches the given pattern.
|
||||
|
||||
=head2 err_unlike
|
||||
|
||||
$run->err_unlike($regex);
|
||||
$run->err_unlike($regex, $message);
|
||||
|
||||
Passes if the standard error of the run does not match the given pattern.
|
||||
|
||||
=head2 note
|
||||
|
||||
$run->note;
|
||||
|
||||
Send the output and standard error as test note.
|
||||
|
||||
=head2 diag
|
||||
|
||||
$run->diag;
|
||||
|
||||
Send the output and standard error as test diagnostic.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::Alien>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Diab Jerius (DJERIUS)
|
||||
|
||||
Roy Storey (KIWIROY)
|
||||
|
||||
Ilya Pavlov
|
||||
|
||||
David Mertens (run4flat)
|
||||
|
||||
Mark Nunberg (mordy, mnunberg)
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
|
||||
Brian Wightman (MidLifeXis)
|
||||
|
||||
Zaki Mughal (zmughal)
|
||||
|
||||
mohawk (mohawk2, ETJ)
|
||||
|
||||
Vikas N Kumar (vikasnkumar)
|
||||
|
||||
Flavio Poletti (polettix)
|
||||
|
||||
Salvador Fandiño (salva)
|
||||
|
||||
Gianni Ceccarelli (dakkar)
|
||||
|
||||
Pavel Shaydo (zwon, trinitum)
|
||||
|
||||
Kang-min Liu (劉康民, gugod)
|
||||
|
||||
Nicholas Shipp (nshp)
|
||||
|
||||
Juan Julián Merelo Guervós (JJ)
|
||||
|
||||
Joel Berger (JBERGER)
|
||||
|
||||
Petr Pisar (ppisar)
|
||||
|
||||
Lance Wicks (LANCEW)
|
||||
|
||||
Ahmad Fatoum (a3f, ATHREEF)
|
||||
|
||||
José Joaquín Atria (JJATRIA)
|
||||
|
||||
Duke Leto (LETO)
|
||||
|
||||
Shoichi Kaji (SKAJI)
|
||||
|
||||
Shawn Laffan (SLAFFAN)
|
||||
|
||||
Paul Evans (leonerd, PEVANS)
|
||||
|
||||
Håkon Hægland (hakonhagland, HAKONH)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011-2020 by Graham Ollis.
|
||||
|
||||
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
|
||||
257
database/perl/vendor/lib/Test/Alien/Synthetic.pm
vendored
Normal file
257
database/perl/vendor/lib/Test/Alien/Synthetic.pm
vendored
Normal file
@@ -0,0 +1,257 @@
|
||||
package Test::Alien::Synthetic;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.008004;
|
||||
use Test2::API qw( context );
|
||||
|
||||
# ABSTRACT: A mock alien object for testing
|
||||
our $VERSION = '2.38'; # VERSION
|
||||
|
||||
|
||||
sub _def ($) { my($val) = @_; defined $val ? $val : '' }
|
||||
|
||||
sub cflags { _def shift->{cflags} }
|
||||
sub libs { _def shift->{libs} }
|
||||
sub dynamic_libs { @{ shift->{dynamic_libs} || [] } }
|
||||
|
||||
sub runtime_prop
|
||||
{
|
||||
my($self) = @_;
|
||||
defined $self->{runtime_prop}
|
||||
? $self->{runtime_prop}
|
||||
: {};
|
||||
}
|
||||
|
||||
sub cflags_static
|
||||
{
|
||||
my($self) = @_;
|
||||
defined $self->{cflags_static}
|
||||
? $self->{cflags_static}
|
||||
: $self->cflags;
|
||||
}
|
||||
|
||||
sub libs_static
|
||||
{
|
||||
my($self) = @_;
|
||||
defined $self->{libs_static}
|
||||
? $self->{libs_static}
|
||||
: $self->libs;
|
||||
}
|
||||
|
||||
sub bin_dir
|
||||
{
|
||||
my $dir = shift->{bin_dir};
|
||||
defined $dir && -d $dir ? ($dir) : ();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Alien::Synthetic - A mock alien object for testing
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.38
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test::Alien;
|
||||
|
||||
my $alien = synthetic {
|
||||
cflags => '-I/foo/bar/include',
|
||||
libs => '-L/foo/bar/lib -lbaz',
|
||||
};
|
||||
|
||||
alien_ok $alien;
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is used to model a synthetic L<Alien>
|
||||
class that implements the minimum L<Alien::Base>
|
||||
interface needed by L<Test::Alien>.
|
||||
|
||||
It can be useful if you have a non-L<Alien::Base>
|
||||
based L<Alien> distribution that you need to test.
|
||||
|
||||
B<NOTE>: The name of this class may move in the
|
||||
future, so do not refer to this class name directly.
|
||||
Instead create instances of this class using the
|
||||
L<Test::Alien#synthetic> function.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 cflags
|
||||
|
||||
String containing the compiler flags
|
||||
|
||||
=head2 cflags_static
|
||||
|
||||
String containing the static compiler flags
|
||||
|
||||
=head2 libs
|
||||
|
||||
String containing the linker and library flags
|
||||
|
||||
=head2 libs_static
|
||||
|
||||
String containing the static linker and library flags
|
||||
|
||||
=head2 dynamic_libs
|
||||
|
||||
List reference containing the dynamic libraries.
|
||||
|
||||
=head2 bin_dir
|
||||
|
||||
Tool binary directory.
|
||||
|
||||
=head2 runtime_prop
|
||||
|
||||
Runtime properties.
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
Here is a complete example using L<Alien::Libarchive> which is a non-L<Alien::Base>
|
||||
based L<Alien> distribution.
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Test2::V0;
|
||||
use Test::Alien;
|
||||
use Alien::Libarchive;
|
||||
|
||||
my $real = Alien::Libarchive->new;
|
||||
my $alien = synthetic {
|
||||
cflags => scalar $real->cflags,
|
||||
libs => scalar $real->libs,
|
||||
dynamic_libs => [$real->dlls],
|
||||
};
|
||||
|
||||
alien_ok $alien;
|
||||
|
||||
xs_ok do { local $/; <DATA> }, with_subtest {
|
||||
my($module) = @_;
|
||||
my $ptr = $module->archive_read_new;
|
||||
like $ptr, qr{^[0-9]+$};
|
||||
$module->archive_read_free($ptr);
|
||||
};
|
||||
|
||||
ffi_ok { symbols => [qw( archive_read_new )] }, with_subtest {
|
||||
my($ffi) = @_;
|
||||
my $new = $ffi->function(archive_read_new => [] => 'opaque');
|
||||
my $free = $ffi->function(archive_read_close => ['opaque'] => 'void');
|
||||
my $ptr = $new->();
|
||||
like $ptr, qr{^[0-9]+$};
|
||||
$free->($ptr);
|
||||
};
|
||||
|
||||
done_testing;
|
||||
|
||||
__DATA__
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
#include <archive.h>
|
||||
|
||||
MODULE = TA_MODULE PACKAGE = TA_MODULE
|
||||
|
||||
void *archive_read_new(class);
|
||||
const char *class;
|
||||
CODE:
|
||||
RETVAL = (void*) archive_read_new();
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
void archive_read_free(class, ptr);
|
||||
const char *class;
|
||||
void *ptr;
|
||||
CODE:
|
||||
archive_read_free(ptr);
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::Alien>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Diab Jerius (DJERIUS)
|
||||
|
||||
Roy Storey (KIWIROY)
|
||||
|
||||
Ilya Pavlov
|
||||
|
||||
David Mertens (run4flat)
|
||||
|
||||
Mark Nunberg (mordy, mnunberg)
|
||||
|
||||
Christian Walde (Mithaldu)
|
||||
|
||||
Brian Wightman (MidLifeXis)
|
||||
|
||||
Zaki Mughal (zmughal)
|
||||
|
||||
mohawk (mohawk2, ETJ)
|
||||
|
||||
Vikas N Kumar (vikasnkumar)
|
||||
|
||||
Flavio Poletti (polettix)
|
||||
|
||||
Salvador Fandiño (salva)
|
||||
|
||||
Gianni Ceccarelli (dakkar)
|
||||
|
||||
Pavel Shaydo (zwon, trinitum)
|
||||
|
||||
Kang-min Liu (劉康民, gugod)
|
||||
|
||||
Nicholas Shipp (nshp)
|
||||
|
||||
Juan Julián Merelo Guervós (JJ)
|
||||
|
||||
Joel Berger (JBERGER)
|
||||
|
||||
Petr Pisar (ppisar)
|
||||
|
||||
Lance Wicks (LANCEW)
|
||||
|
||||
Ahmad Fatoum (a3f, ATHREEF)
|
||||
|
||||
José Joaquín Atria (JJATRIA)
|
||||
|
||||
Duke Leto (LETO)
|
||||
|
||||
Shoichi Kaji (SKAJI)
|
||||
|
||||
Shawn Laffan (SLAFFAN)
|
||||
|
||||
Paul Evans (leonerd, PEVANS)
|
||||
|
||||
Håkon Hægland (hakonhagland, HAKONH)
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011-2020 by Graham Ollis.
|
||||
|
||||
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
|
||||
695
database/perl/vendor/lib/Test/Base.pm
vendored
Normal file
695
database/perl/vendor/lib/Test/Base.pm
vendored
Normal file
@@ -0,0 +1,695 @@
|
||||
package Test::Base;
|
||||
our $VERSION = '0.89';
|
||||
|
||||
use Spiffy -Base;
|
||||
use Spiffy ':XXX';
|
||||
|
||||
my $HAS_PROVIDER;
|
||||
BEGIN {
|
||||
$HAS_PROVIDER = eval "require Test::Builder::Provider; 1";
|
||||
|
||||
if ($HAS_PROVIDER) {
|
||||
Test::Builder::Provider->import('provides');
|
||||
}
|
||||
else {
|
||||
*provides = sub { 1 };
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
my @test_more_exports;
|
||||
BEGIN {
|
||||
@test_more_exports = qw(
|
||||
ok isnt like unlike is_deeply cmp_ok
|
||||
skip todo_skip pass fail
|
||||
eq_array eq_hash eq_set
|
||||
plan can_ok isa_ok diag
|
||||
use_ok
|
||||
$TODO
|
||||
);
|
||||
}
|
||||
|
||||
use Test::More import => \@test_more_exports;
|
||||
use Carp;
|
||||
|
||||
our @EXPORT = (@test_more_exports, qw(
|
||||
is no_diff
|
||||
|
||||
blocks next_block first_block
|
||||
delimiters spec_file spec_string
|
||||
filters filters_delay filter_arguments
|
||||
run run_compare run_is run_is_deeply run_like run_unlike
|
||||
skip_all_unless_require is_deep run_is_deep
|
||||
WWW XXX YYY ZZZ
|
||||
tie_output no_diag_on_only
|
||||
|
||||
find_my_self default_object
|
||||
|
||||
croak carp cluck confess
|
||||
));
|
||||
|
||||
field '_spec_file';
|
||||
field '_spec_string';
|
||||
field _filters => [qw(norm trim)];
|
||||
field _filters_map => {};
|
||||
field spec =>
|
||||
-init => '$self->_spec_init';
|
||||
field block_list =>
|
||||
-init => '$self->_block_list_init';
|
||||
field _next_list => [];
|
||||
field block_delim =>
|
||||
-init => '$self->block_delim_default';
|
||||
field data_delim =>
|
||||
-init => '$self->data_delim_default';
|
||||
field _filters_delay => 0;
|
||||
field _no_diag_on_only => 0;
|
||||
|
||||
field block_delim_default => '===';
|
||||
field data_delim_default => '---';
|
||||
|
||||
my $default_class;
|
||||
my $default_object;
|
||||
my $reserved_section_names = {};
|
||||
|
||||
sub default_object {
|
||||
$default_object ||= $default_class->new;
|
||||
return $default_object;
|
||||
}
|
||||
|
||||
my $import_called = 0;
|
||||
sub import() {
|
||||
$import_called = 1;
|
||||
my $class = (grep /^-base$/i, @_)
|
||||
? scalar(caller)
|
||||
: $_[0];
|
||||
if (not defined $default_class) {
|
||||
$default_class = $class;
|
||||
}
|
||||
# else {
|
||||
# croak "Can't use $class after using $default_class"
|
||||
# unless $default_class->isa($class);
|
||||
# }
|
||||
|
||||
unless (grep /^-base$/i, @_) {
|
||||
my @args;
|
||||
for (my $ii = 1; $ii <= $#_; ++$ii) {
|
||||
if ($_[$ii] eq '-package') {
|
||||
++$ii;
|
||||
} else {
|
||||
push @args, $_[$ii];
|
||||
}
|
||||
}
|
||||
Test::More->import(import => \@test_more_exports, @args)
|
||||
if @args;
|
||||
}
|
||||
|
||||
_strict_warnings();
|
||||
goto &Spiffy::import;
|
||||
}
|
||||
|
||||
# Wrap Test::Builder::plan
|
||||
my $plan_code = \&Test::Builder::plan;
|
||||
my $Have_Plan = 0;
|
||||
{
|
||||
no warnings 'redefine';
|
||||
*Test::Builder::plan = sub {
|
||||
$Have_Plan = 1;
|
||||
goto &$plan_code;
|
||||
};
|
||||
}
|
||||
|
||||
my $DIED = 0;
|
||||
$SIG{__DIE__} = sub { $DIED = 1; die @_ };
|
||||
|
||||
sub block_class { $self->find_class('Block') }
|
||||
sub filter_class { $self->find_class('Filter') }
|
||||
|
||||
sub find_class {
|
||||
my $suffix = shift;
|
||||
my $class = ref($self) . "::$suffix";
|
||||
return $class if $class->can('new');
|
||||
$class = __PACKAGE__ . "::$suffix";
|
||||
return $class if $class->can('new');
|
||||
eval "require $class";
|
||||
return $class if $class->can('new');
|
||||
die "Can't find a class for $suffix";
|
||||
}
|
||||
|
||||
sub check_late {
|
||||
if ($self->{block_list}) {
|
||||
my $caller = (caller(1))[3];
|
||||
$caller =~ s/.*:://;
|
||||
croak "Too late to call $caller()"
|
||||
}
|
||||
}
|
||||
|
||||
sub find_my_self() {
|
||||
my $self = ref($_[0]) eq $default_class
|
||||
? splice(@_, 0, 1)
|
||||
: default_object();
|
||||
return $self, @_;
|
||||
}
|
||||
|
||||
sub blocks() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
|
||||
croak "Invalid arguments passed to 'blocks'"
|
||||
if @_ > 1;
|
||||
croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
|
||||
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
|
||||
|
||||
my $blocks = $self->block_list;
|
||||
|
||||
my $section_name = shift || '';
|
||||
my @blocks = $section_name
|
||||
? (grep { exists $_->{$section_name} } @$blocks)
|
||||
: (@$blocks);
|
||||
|
||||
return scalar(@blocks) unless wantarray;
|
||||
|
||||
return (@blocks) if $self->_filters_delay;
|
||||
|
||||
for my $block (@blocks) {
|
||||
$block->run_filters
|
||||
unless $block->is_filtered;
|
||||
}
|
||||
|
||||
return (@blocks);
|
||||
}
|
||||
|
||||
sub next_block() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my $list = $self->_next_list;
|
||||
if (@$list == 0) {
|
||||
$list = [@{$self->block_list}, undef];
|
||||
$self->_next_list($list);
|
||||
}
|
||||
my $block = shift @$list;
|
||||
if (defined $block and not $block->is_filtered) {
|
||||
$block->run_filters;
|
||||
}
|
||||
return $block;
|
||||
}
|
||||
|
||||
sub first_block() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_next_list([]);
|
||||
$self->next_block;
|
||||
}
|
||||
|
||||
sub filters_delay() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_filters_delay(defined $_[0] ? shift : 1);
|
||||
}
|
||||
|
||||
sub no_diag_on_only() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_no_diag_on_only(defined $_[0] ? shift : 1);
|
||||
}
|
||||
|
||||
sub delimiters() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->check_late;
|
||||
my ($block_delimiter, $data_delimiter) = @_;
|
||||
$block_delimiter ||= $self->block_delim_default;
|
||||
$data_delimiter ||= $self->data_delim_default;
|
||||
$self->block_delim($block_delimiter);
|
||||
$self->data_delim($data_delimiter);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub spec_file() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->check_late;
|
||||
$self->_spec_file(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub spec_string() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->check_late;
|
||||
$self->_spec_string(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub filters() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
if (ref($_[0]) eq 'HASH') {
|
||||
$self->_filters_map(shift);
|
||||
}
|
||||
else {
|
||||
my $filters = $self->_filters;
|
||||
push @$filters, @_;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub filter_arguments() {
|
||||
$Test::Base::Filter::arguments;
|
||||
}
|
||||
|
||||
sub have_text_diff {
|
||||
eval { require Text::Diff; 1 } &&
|
||||
$Text::Diff::VERSION >= 0.35 &&
|
||||
$Algorithm::Diff::VERSION >= 1.15;
|
||||
}
|
||||
|
||||
provides 'is';
|
||||
sub is($$;$) {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my ($actual, $expected, $name) = @_;
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER;
|
||||
if ($ENV{TEST_SHOW_NO_DIFFS} or
|
||||
not defined $actual or
|
||||
not defined $expected or
|
||||
$actual eq $expected or
|
||||
not($self->have_text_diff) or
|
||||
$expected !~ /\n./s
|
||||
) {
|
||||
Test::More::is($actual, $expected, $name);
|
||||
}
|
||||
else {
|
||||
$name = '' unless defined $name;
|
||||
ok $actual eq $expected, $name;
|
||||
diag Text::Diff::diff(\$expected, \$actual);
|
||||
}
|
||||
}
|
||||
|
||||
sub run(&;$) {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my $callback = shift;
|
||||
for my $block (@{$self->block_list}) {
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
&{$callback}($block);
|
||||
}
|
||||
}
|
||||
|
||||
my $name_error = "Can't determine section names";
|
||||
sub _section_names {
|
||||
return unless defined $self->spec;
|
||||
return @_ if @_ == 2;
|
||||
my $block = $self->first_block
|
||||
or croak $name_error;
|
||||
my @names = grep {
|
||||
$_ !~ /^(ONLY|LAST|SKIP)$/;
|
||||
} @{$block->{_section_order}[0] || []};
|
||||
croak "$name_error. Need two sections in first block"
|
||||
unless @names == 2;
|
||||
return @names;
|
||||
}
|
||||
|
||||
sub _assert_plan {
|
||||
plan('no_plan') unless $Have_Plan;
|
||||
}
|
||||
|
||||
sub END {
|
||||
run_compare() unless $Have_Plan or $DIED or not $import_called;
|
||||
}
|
||||
|
||||
sub run_compare() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
return unless defined $self->spec;
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
if (ref $block->$x) {
|
||||
is_deeply($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ());
|
||||
}
|
||||
elsif (ref $block->$y eq 'Regexp') {
|
||||
my $regexp = ref $y ? $y : $block->$y;
|
||||
like($block->$x, $regexp, $block->name ? $block->name : ());
|
||||
}
|
||||
else {
|
||||
is($block->$x, $block->$y, $block->name ? $block->name : ());
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub run_is() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
is($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub run_is_deeply() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
is_deeply($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub run_like() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and defined($y);
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
my $regexp = ref $y ? $y : $block->$y;
|
||||
like($block->$x, $regexp,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub run_unlike() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and defined($y);
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
my $regexp = ref $y ? $y : $block->$y;
|
||||
unlike($block->$x, $regexp,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub skip_all_unless_require() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my $module = shift;
|
||||
eval "require $module; 1"
|
||||
or Test::More::plan(
|
||||
skip_all => "$module failed to load"
|
||||
);
|
||||
}
|
||||
|
||||
sub is_deep() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
require Test::Deep;
|
||||
Test::Deep::cmp_deeply(@_);
|
||||
}
|
||||
|
||||
sub run_is_deep() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
is_deep($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub _pre_eval {
|
||||
my $spec = shift;
|
||||
return unless defined $spec;
|
||||
return $spec unless $spec =~
|
||||
s/\A\s*<<<(.*?)>>>\s*$//sm;
|
||||
my $eval_code = $1;
|
||||
eval "package main; $eval_code";
|
||||
croak $@ if $@;
|
||||
return $spec;
|
||||
}
|
||||
|
||||
sub _block_list_init {
|
||||
my $spec = $self->spec;
|
||||
return [] unless defined $spec;
|
||||
$spec = $self->_pre_eval($spec);
|
||||
my $cd = $self->block_delim;
|
||||
my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
|
||||
my $blocks = $self->_choose_blocks(@hunks);
|
||||
$self->block_list($blocks); # Need to set early for possible filter use
|
||||
my $seq = 1;
|
||||
for my $block (@$blocks) {
|
||||
$block->blocks_object($self);
|
||||
$block->seq_num($seq++);
|
||||
}
|
||||
return $blocks;
|
||||
}
|
||||
|
||||
sub _choose_blocks {
|
||||
my $blocks = [];
|
||||
for my $hunk (@_) {
|
||||
my $block = $self->_make_block($hunk);
|
||||
if (exists $block->{ONLY}) {
|
||||
diag "I found ONLY: maybe you're debugging?"
|
||||
unless $self->_no_diag_on_only;
|
||||
return [$block];
|
||||
}
|
||||
next if exists $block->{SKIP};
|
||||
push @$blocks, $block;
|
||||
if (exists $block->{LAST}) {
|
||||
return $blocks;
|
||||
}
|
||||
}
|
||||
return $blocks;
|
||||
}
|
||||
|
||||
sub _check_reserved {
|
||||
my $id = shift;
|
||||
croak "'$id' is a reserved name. Use something else.\n"
|
||||
if $reserved_section_names->{$id} or
|
||||
$id =~ /^_/;
|
||||
}
|
||||
|
||||
sub _make_block {
|
||||
my $hunk = shift;
|
||||
my $cd = $self->block_delim;
|
||||
my $dd = $self->data_delim;
|
||||
my $block = $self->block_class->new;
|
||||
$hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
|
||||
my $name = $1;
|
||||
my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
|
||||
my $description = shift @parts;
|
||||
$description ||= '';
|
||||
unless ($description =~ /\S/) {
|
||||
$description = $name;
|
||||
}
|
||||
$description =~ s/\s*\z//;
|
||||
$block->set_value(description => $description);
|
||||
|
||||
my $section_map = {};
|
||||
my $section_order = [];
|
||||
while (@parts) {
|
||||
my ($type, $filters, $value) = splice(@parts, 0, 3);
|
||||
$self->_check_reserved($type);
|
||||
$value = '' unless defined $value;
|
||||
$filters = '' unless defined $filters;
|
||||
if ($filters =~ /:(\s|\z)/) {
|
||||
croak "Extra lines not allowed in '$type' section"
|
||||
if $value =~ /\S/;
|
||||
($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
|
||||
$value = '' unless defined $value;
|
||||
$value =~ s/^\s*(.*?)\s*$/$1/;
|
||||
}
|
||||
$section_map->{$type} = {
|
||||
filters => $filters,
|
||||
};
|
||||
push @$section_order, $type;
|
||||
$block->set_value($type, $value);
|
||||
}
|
||||
$block->set_value(name => $name);
|
||||
$block->set_value(_section_map => $section_map);
|
||||
$block->set_value(_section_order => $section_order);
|
||||
return $block;
|
||||
}
|
||||
|
||||
sub _spec_init {
|
||||
return $self->_spec_string
|
||||
if $self->_spec_string;
|
||||
local $/;
|
||||
my $spec;
|
||||
if (my $spec_file = $self->_spec_file) {
|
||||
open FILE, $spec_file or die $!;
|
||||
$spec = <FILE>;
|
||||
close FILE;
|
||||
}
|
||||
else {
|
||||
require Scalar::Util;
|
||||
my $handle = Scalar::Util::openhandle( \*main::DATA );
|
||||
if ($handle) {
|
||||
$spec = <$handle>;
|
||||
}
|
||||
}
|
||||
return $spec;
|
||||
}
|
||||
|
||||
sub _strict_warnings() {
|
||||
require Filter::Util::Call;
|
||||
my $done = 0;
|
||||
Filter::Util::Call::filter_add(
|
||||
sub {
|
||||
return 0 if $done;
|
||||
my ($data, $end) = ('', '');
|
||||
while (my $status = Filter::Util::Call::filter_read()) {
|
||||
return $status if $status < 0;
|
||||
if (/^__(?:END|DATA)__\r?$/) {
|
||||
$end = $_;
|
||||
last;
|
||||
}
|
||||
$data .= $_;
|
||||
$_ = '';
|
||||
}
|
||||
$_ = "use strict;use warnings;$data$end";
|
||||
$done = 1;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub tie_output() {
|
||||
my $handle = shift;
|
||||
die "No buffer to tie" unless @_;
|
||||
tie *$handle, 'Test::Base::Handle', $_[0];
|
||||
}
|
||||
|
||||
sub no_diff {
|
||||
$ENV{TEST_SHOW_NO_DIFFS} = 1;
|
||||
}
|
||||
|
||||
package Test::Base::Handle;
|
||||
|
||||
sub TIEHANDLE() {
|
||||
my $class = shift;
|
||||
bless \ $_[0], $class;
|
||||
}
|
||||
|
||||
sub PRINT {
|
||||
$$self .= $_ for @_;
|
||||
}
|
||||
|
||||
#===============================================================================
|
||||
# Test::Base::Block
|
||||
#
|
||||
# This is the default class for accessing a Test::Base block object.
|
||||
#===============================================================================
|
||||
package Test::Base::Block;
|
||||
our @ISA = qw(Spiffy);
|
||||
|
||||
our @EXPORT = qw(block_accessor);
|
||||
|
||||
sub AUTOLOAD {
|
||||
return;
|
||||
}
|
||||
|
||||
sub block_accessor() {
|
||||
my $accessor = shift;
|
||||
no strict 'refs';
|
||||
return if defined &$accessor;
|
||||
*$accessor = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
Carp::croak "Not allowed to set values for '$accessor'";
|
||||
}
|
||||
my @list = @{$self->{$accessor} || []};
|
||||
return wantarray
|
||||
? (@list)
|
||||
: $list[0];
|
||||
};
|
||||
}
|
||||
|
||||
block_accessor 'name';
|
||||
block_accessor 'description';
|
||||
Spiffy::field 'seq_num';
|
||||
Spiffy::field 'is_filtered';
|
||||
Spiffy::field 'blocks_object';
|
||||
Spiffy::field 'original_values' => {};
|
||||
|
||||
sub set_value {
|
||||
no strict 'refs';
|
||||
my $accessor = shift;
|
||||
block_accessor $accessor
|
||||
unless defined &$accessor;
|
||||
$self->{$accessor} = [@_];
|
||||
}
|
||||
|
||||
sub run_filters {
|
||||
my $map = $self->_section_map;
|
||||
my $order = $self->_section_order;
|
||||
Carp::croak "Attempt to filter a block twice"
|
||||
if $self->is_filtered;
|
||||
for my $type (@$order) {
|
||||
my $filters = $map->{$type}{filters};
|
||||
my @value = $self->$type;
|
||||
$self->original_values->{$type} = $value[0];
|
||||
for my $filter ($self->_get_filters($type, $filters)) {
|
||||
$Test::Base::Filter::arguments =
|
||||
$filter =~ s/=(.*)$// ? $1 : undef;
|
||||
my $function = "main::$filter";
|
||||
no strict 'refs';
|
||||
if (defined &$function) {
|
||||
local $_ =
|
||||
(@value == 1 and not defined($value[0])) ? undef :
|
||||
join '', @value;
|
||||
my $old = $_;
|
||||
@value = &$function(@value);
|
||||
if (not(@value) or
|
||||
@value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/
|
||||
) {
|
||||
if ($value[0] && $_ eq $old) {
|
||||
Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't.");
|
||||
}
|
||||
@value = ($_);
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $filter_object = $self->blocks_object->filter_class->new;
|
||||
die "Can't find a function or method for '$filter' filter\n"
|
||||
unless $filter_object->can($filter);
|
||||
$filter_object->current_block($self);
|
||||
@value = $filter_object->$filter(@value);
|
||||
}
|
||||
# Set the value after each filter since other filters may be
|
||||
# introspecting.
|
||||
$self->set_value($type, @value);
|
||||
}
|
||||
}
|
||||
$self->is_filtered(1);
|
||||
}
|
||||
|
||||
sub _get_filters {
|
||||
my $type = shift;
|
||||
my $string = shift || '';
|
||||
$string =~ s/\s*(.*?)\s*/$1/;
|
||||
my @filters = ();
|
||||
my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
|
||||
$map_filters = [ $map_filters ] unless ref $map_filters;
|
||||
my @append = ();
|
||||
for (
|
||||
@{$self->blocks_object->_filters},
|
||||
@$map_filters,
|
||||
split(/\s+/, $string),
|
||||
) {
|
||||
my $filter = $_;
|
||||
last unless length $filter;
|
||||
if ($filter =~ s/^-//) {
|
||||
@filters = grep { $_ ne $filter } @filters;
|
||||
}
|
||||
elsif ($filter =~ s/^\+//) {
|
||||
push @append, $filter;
|
||||
}
|
||||
else {
|
||||
push @filters, $filter;
|
||||
}
|
||||
}
|
||||
return @filters, @append;
|
||||
}
|
||||
|
||||
{
|
||||
%$reserved_section_names = map {
|
||||
($_, 1);
|
||||
} keys(%Test::Base::Block::), qw( new DESTROY );
|
||||
}
|
||||
|
||||
1;
|
||||
697
database/perl/vendor/lib/Test/Base.pod
vendored
Normal file
697
database/perl/vendor/lib/Test/Base.pod
vendored
Normal file
@@ -0,0 +1,697 @@
|
||||
=pod
|
||||
|
||||
=for comment
|
||||
DO NOT EDIT. This Pod was generated by Swim v0.1.46.
|
||||
See http://github.com/ingydotnet/swim-pm#readme
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Base - A Data Driven Testing Framework
|
||||
|
||||
=for html
|
||||
<a href="https://travis-ci.org/ingydotnet/test-base-pm"><img src="https://travis-ci.org/ingydotnet/test-base-pm.png" alt="test-base-pm"></a>
|
||||
<a href="https://coveralls.io/r/ingydotnet/test-base-pm?branch=master"><img src="https://coveralls.io/repos/ingydotnet/test-base-pm/badge.png" alt="test-base-pm"></a>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A new test module:
|
||||
|
||||
# lib/MyProject/Test.pm
|
||||
package MyProject::Test;
|
||||
use Test::Base -Base;
|
||||
|
||||
use MyProject;
|
||||
|
||||
package MyProject::Test::Filter;
|
||||
use Test::Base::Filter -base;
|
||||
|
||||
sub my_filter {
|
||||
return MyProject->do_something(shift);
|
||||
}
|
||||
|
||||
A sample test:
|
||||
|
||||
# t/sample.t
|
||||
use MyProject::Test;
|
||||
|
||||
plan tests => 1 * blocks;
|
||||
|
||||
run_is input => 'expected';
|
||||
|
||||
sub local_filter {
|
||||
s/my/your/;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=== Test one (the name of the test)
|
||||
--- input my_filter local_filter
|
||||
my
|
||||
input
|
||||
lines
|
||||
--- expected
|
||||
expected
|
||||
output
|
||||
|
||||
=== Test two
|
||||
This is an optional description
|
||||
of this particular test.
|
||||
--- input my_filter
|
||||
other
|
||||
input
|
||||
lines
|
||||
--- expected
|
||||
other expected
|
||||
output
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Testing is usually the ugly part of Perl module authoring. Perl gives you a
|
||||
standard way to run tests with Test::Harness, and basic testing primitives
|
||||
with Test::More. After that you are pretty much on your own to develop a
|
||||
testing framework and philosophy. Test::More encourages you to make your own
|
||||
framework by subclassing Test::Builder, but that is not trivial.
|
||||
|
||||
Test::Base gives you a way to write your own test framework base class that
|
||||
I<is> trivial. In fact it is as simple as two lines:
|
||||
|
||||
package MyTestFramework;
|
||||
use Test::Base -Base;
|
||||
|
||||
A module called C<MyTestFramework.pm> containing those two lines, will give
|
||||
all the power of Test::More and all the power of Test::Base to every test file
|
||||
that uses it. As you build up the capabilities of C<MyTestFramework>, your
|
||||
tests will have all of that power as well.
|
||||
|
||||
C<MyTestFramework> becomes a place for you to put all of your reusable testing
|
||||
bits. As you write tests, you will see patterns and duplication, and you can
|
||||
"upstream" them into C<MyTestFramework>. Of course, you don't have to subclass
|
||||
Test::Base at all. You can use it directly in many applications, including
|
||||
everywhere you would use Test::More.
|
||||
|
||||
Test::Base concentrates on offering reusable data driven patterns, so that you
|
||||
can write tests with a minimum of code. At the heart of all testing you have
|
||||
inputs, processes and expected outputs. Test::Base provides some clean ways
|
||||
for you to express your input and expected output data, so you can spend your
|
||||
|
||||
time focusing on that rather than your code scaffolding.
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
Test::Base extends Test::More and exports all of its functions. So you can
|
||||
basically write your tests the same as Test::More. Test::Base also exports
|
||||
many functions of its own:
|
||||
|
||||
=over
|
||||
|
||||
=item C<is(actual, expected, [test-name])>
|
||||
|
||||
This is the equivalent of Test::More's C<is> function with one interesting
|
||||
twist. If your actual and expected results differ and the output is multi-
|
||||
line, this function will show you a unified diff format of output. Consider
|
||||
the benefit when looking for the one character that is different in hundreds
|
||||
of lines of output!
|
||||
|
||||
Diff output requires the optional C<Text::Diff> CPAN module. If you don't have
|
||||
this module, the C<is()> function will simply give you normal Test::More
|
||||
output. To disable diffing altogether, set the C<TEST_SHOW_NO_DIFFS>
|
||||
environment variable (or C<$ENV{TEST_SHOW_NO_DIFFS}>) to a true value. You can
|
||||
also call the C<no_diff> function as a shortcut.
|
||||
|
||||
=item C<blocks( [data-section-name] )>
|
||||
|
||||
The most important function is C<blocks>. In list context it returns a list of
|
||||
C<Test::Base::Block> objects that are generated from the test specification in
|
||||
the C<DATA> section of your test file. In scalar context it returns the number
|
||||
of objects. This is useful to calculate your Test::More plan.
|
||||
|
||||
Each Test::Base::Block object has methods that correspond to the names of that
|
||||
object's data sections. There is also a C<name> and a C<description> method
|
||||
for accessing those parts of the block if they were specified.
|
||||
|
||||
The C<blocks> function can take an optional single argument, that indicates to
|
||||
only return the blocks that contain a particular named data section. Otherwise
|
||||
C<blocks> returns all blocks.
|
||||
|
||||
my @all_of_my_blocks = blocks;
|
||||
|
||||
my @just_the_foo_blocks = blocks('foo');
|
||||
|
||||
=item C<next_block()>
|
||||
|
||||
You can use the next_block function to iterate over all the blocks.
|
||||
|
||||
while (my $block = next_block) {
|
||||
...
|
||||
}
|
||||
|
||||
It returns undef after all blocks have been iterated over. It can then be
|
||||
called again to reiterate.
|
||||
|
||||
=item C<first_block()>
|
||||
|
||||
Returns the first block or undef if there are none. It resets the iterator to
|
||||
the C<next_block> function.
|
||||
|
||||
=item C<run(&subroutine)>
|
||||
|
||||
There are many ways to write your tests. You can reference each block
|
||||
individually or you can loop over all the blocks and perform a common
|
||||
operation. The C<run> function does the looping for you, so all you need to do
|
||||
is pass it a code block to execute for each block.
|
||||
|
||||
The C<run> function takes a subroutine as an argument, and calls the sub one
|
||||
time for each block in the specification. It passes the current block object
|
||||
to the subroutine.
|
||||
|
||||
run {
|
||||
my $block = shift;
|
||||
is(process($block->foo), $block->bar, $block->name);
|
||||
};
|
||||
|
||||
=item C<run_is([data_name1, data_name2])>
|
||||
|
||||
Many times you simply want to see if two data sections are equivalent in
|
||||
every block, probably after having been run through one or more filters. With
|
||||
the C<run_is> function, you can just pass the names of any two data sections
|
||||
that exist in every block, and it will loop over every block comparing the
|
||||
two sections.
|
||||
|
||||
run_is 'foo', 'bar';
|
||||
|
||||
If no data sections are given C<run_is> will try to detect them automatically.
|
||||
|
||||
NOTE: Test::Base will silently ignore any blocks that don't contain
|
||||
both sections.
|
||||
|
||||
=item C<is_deep($data1, $data2, $test_name)>
|
||||
|
||||
Like Test::More's C<is_deeply> but uses the more correct Test::Deep module.
|
||||
|
||||
=item C<run_is_deeply([data_name1, data_name2])>
|
||||
|
||||
Like C<run_is_deeply> but uses C<is_deep> which uses the more correct
|
||||
Test::Deep.
|
||||
|
||||
=item C<run_is_deeply([data_name1, data_name2])>
|
||||
|
||||
Like C<run_is> but uses C<is_deeply> for complex data structure comparison.
|
||||
|
||||
=item C<run_is_deeply([data_name1, data_name2])>
|
||||
|
||||
Like C<run_is_deeply> but uses C<is_deep> which uses the more correct
|
||||
Test::Deep.
|
||||
|
||||
=item C<run_like([data_name, regexp | data_name]);>
|
||||
|
||||
The C<run_like> function is similar to C<run_is> except the second argument is
|
||||
a regular expression. The regexp can either be a C<qr{}> object or a data
|
||||
section that has been filtered into a regular expression.
|
||||
|
||||
run_like 'foo', qr{<html.*};
|
||||
run_like 'foo', 'match';
|
||||
|
||||
=item C<run_unlike([data_name, regexp | data_name]);>
|
||||
|
||||
The C<run_unlike> function is similar to C<run_like>, except the opposite.
|
||||
|
||||
run_unlike 'foo', qr{<html.*};
|
||||
run_unlike 'foo', 'no_match';
|
||||
|
||||
=item C<run_compare(data_name1, data_name2)>
|
||||
|
||||
The C<run_compare> function is like the C<run_is>, C<run_is_deeply> and the
|
||||
C<run_like> functions all rolled into one. It loops over each relevant block
|
||||
and determines what type of comparison to do.
|
||||
|
||||
NOTE: If you do not specify either a plan, or run any tests, the
|
||||
C<run_compare> function will automatically be run.
|
||||
|
||||
=item C<delimiters($block_delimiter, $data_delimiter)>
|
||||
|
||||
Override the default delimiters of C<===> and C<--->.
|
||||
|
||||
=item C<spec_file($file_name)>
|
||||
|
||||
By default, Test::Base reads its input from the DATA section. This function
|
||||
tells it to get the spec from a file instead.
|
||||
|
||||
=item C<spec_string($test_data)>
|
||||
|
||||
By default, Test::Base reads its input from the DATA section. This function
|
||||
tells it to get the spec from a string that has been prepared somehow.
|
||||
|
||||
=item C<filters( @filters_list or $filters_hashref )>
|
||||
|
||||
Specify a list of additional filters to be applied to all blocks. See
|
||||
C<FILTERS> below.
|
||||
|
||||
You can also specify a hash ref that maps data section names to an array ref
|
||||
of filters for that data type.
|
||||
|
||||
filters {
|
||||
xxx => [qw(chomp lines)],
|
||||
yyy => ['yaml'],
|
||||
zzz => 'eval',
|
||||
};
|
||||
|
||||
If a filters list has only one element, the array ref is optional.
|
||||
|
||||
=item C<filters_delay( [1 | 0] );>
|
||||
|
||||
By default Test::Base::Block objects are have all their filters run ahead of
|
||||
time. There are testing situations in which it is advantageous to delay the
|
||||
filtering. Calling this function with no arguments or a true value, causes the
|
||||
filtering to be delayed.
|
||||
|
||||
use Test::Base;
|
||||
filters_delay;
|
||||
plan tests => 1 * blocks;
|
||||
for my $block (blocks) {
|
||||
...
|
||||
$block->run_filters;
|
||||
ok($block->is_filtered);
|
||||
...
|
||||
}
|
||||
|
||||
In the code above, the filters are called manually, using the C<run_filters>
|
||||
method of Test::Base::Block. In functions like C<run_is>, where the tests are
|
||||
run automatically, filtering is delayed until right before the test.
|
||||
|
||||
=item C<filter_arguments()>
|
||||
|
||||
Return the arguments after the equals sign on a filter.
|
||||
|
||||
sub my_filter {
|
||||
my $args = filter_arguments;
|
||||
# is($args, 'whazzup');
|
||||
...
|
||||
}
|
||||
|
||||
__DATA__
|
||||
=== A test
|
||||
--- data my_filter=whazzup
|
||||
|
||||
=item C<tie_output()>
|
||||
|
||||
You can capture STDOUT and STDERR for operations with this function:
|
||||
|
||||
my $out = '';
|
||||
tie_output(*STDOUT, $out);
|
||||
print "Hey!\n";
|
||||
print "Che!\n";
|
||||
untie *STDOUT;
|
||||
is($out, "Hey!\nChe!\n");
|
||||
|
||||
=item C<no_diff()>
|
||||
|
||||
Turn off diff support for is() in a test file.
|
||||
|
||||
=item C<default_object()>
|
||||
|
||||
Returns the default Test::Base object. This is useful if you feel the need to
|
||||
do an OO operation in otherwise functional test code. See L<OO> below.
|
||||
|
||||
=item C<WWW() XXX() YYY() ZZZ()>
|
||||
|
||||
These debugging functions are exported from the Spiffy.pm module. See
|
||||
L<Spiffy> for more info.
|
||||
|
||||
=item C<croak() carp() cluck() confess()>
|
||||
|
||||
You can use the functions from the Carp module without needing to import them.
|
||||
Test::Base does it for you by default.
|
||||
|
||||
=back
|
||||
|
||||
=head1 TEST SPECIFICATION
|
||||
|
||||
Test::Base allows you to specify your test data in an external file, the
|
||||
DATA section of your program or from a scalar variable containing all the
|
||||
text input.
|
||||
|
||||
A I<test specification> is a series of text lines. Each test (or block) is
|
||||
separated by a line containing the block delimiter and an optional test
|
||||
C<name>. Each block is further subdivided into named sections with a line
|
||||
containing the data delimiter and the data section name. A C<description>
|
||||
of the test can go on lines after the block delimiter but before the first
|
||||
data section.
|
||||
|
||||
Here is the basic layout of a specification:
|
||||
|
||||
=== <block name 1>
|
||||
<optional block description lines>
|
||||
--- <data section name 1> <filter-1> <filter-2> <filter-n>
|
||||
<test data lines>
|
||||
--- <data section name 2> <filter-1> <filter-2> <filter-n>
|
||||
<test data lines>
|
||||
--- <data section name n> <filter-1> <filter-2> <filter-n>
|
||||
<test data lines>
|
||||
|
||||
=== <block name 2>
|
||||
<optional block description lines>
|
||||
--- <data section name 1> <filter-1> <filter-2> <filter-n>
|
||||
<test data lines>
|
||||
--- <data section name 2> <filter-1> <filter-2> <filter-n>
|
||||
<test data lines>
|
||||
--- <data section name n> <filter-1> <filter-2> <filter-n>
|
||||
<test data lines>
|
||||
|
||||
Here is a code example:
|
||||
|
||||
use Test::Base;
|
||||
|
||||
delimiters qw(### :::);
|
||||
|
||||
# test code here
|
||||
|
||||
__END__
|
||||
|
||||
### Test One
|
||||
We want to see if foo and bar
|
||||
are really the same...
|
||||
::: foo
|
||||
a foo line
|
||||
another foo line
|
||||
|
||||
::: bar
|
||||
a bar line
|
||||
another bar line
|
||||
|
||||
### Test Two
|
||||
|
||||
::: foo
|
||||
some foo line
|
||||
some other foo line
|
||||
|
||||
::: bar
|
||||
some bar line
|
||||
some other bar line
|
||||
|
||||
::: baz
|
||||
some baz line
|
||||
some other baz line
|
||||
|
||||
This example specifies two blocks. They both have foo and bar data sections.
|
||||
The second block has a baz component. The block delimiter is C<###> and the
|
||||
data delimiter is C<:::>.
|
||||
|
||||
The default block delimiter is C<===> and the default data delimiter is C<---
|
||||
>.
|
||||
|
||||
There are some special data section names used for control purposes:
|
||||
|
||||
--- SKIP
|
||||
--- ONLY
|
||||
--- LAST
|
||||
|
||||
A block with a SKIP section causes that test to be ignored. This is useful to
|
||||
disable a test temporarily.
|
||||
|
||||
A block with an ONLY section causes only that block to be used. This is useful
|
||||
when you are concentrating on getting a single test to pass. If there is more
|
||||
than one block with ONLY, the first one will be chosen.
|
||||
|
||||
Because ONLY is very useful for debugging and sometimes you forgot to remove
|
||||
the ONLY flag before committing to the VCS or uploading to CPAN, Test::Base by
|
||||
default gives you a diag message saying I<I found ONLY ... maybe you're
|
||||
debugging?>. If you don't like it, use C<no_diag_on_only>.
|
||||
|
||||
A block with a LAST section makes that block the last one in the
|
||||
specification. All following blocks will be ignored.
|
||||
|
||||
=head1 FILTERS
|
||||
|
||||
The real power in writing tests with Test::Base comes from its filtering
|
||||
capabilities. Test::Base comes with an ever growing set of useful generic
|
||||
filters than you can sequence and apply to various test blocks. That means you
|
||||
can specify the block serialization in the most readable format you can find,
|
||||
and let the filters translate it into what you really need for a test. It is
|
||||
easy to write your own filters as well.
|
||||
|
||||
Test::Base allows you to specify a list of filters to each data section of
|
||||
each block. The default filters are C<norm> and C<trim>. These filters will be
|
||||
applied (in order) to the data after it has been parsed from the specification
|
||||
and before it is set into its Test::Base::Block object.
|
||||
|
||||
You can add to the default filter list with the C<filters> function. You can
|
||||
specify additional filters to a specific block by listing them after the
|
||||
section name on a data section delimiter line.
|
||||
|
||||
Example:
|
||||
|
||||
use Test::Base;
|
||||
|
||||
filters qw(foo bar);
|
||||
filters { perl => 'strict' };
|
||||
|
||||
sub upper { uc(shift) }
|
||||
|
||||
__END__
|
||||
|
||||
=== Test one
|
||||
--- foo trim chomp upper
|
||||
...
|
||||
|
||||
--- bar -norm
|
||||
...
|
||||
|
||||
--- perl eval dumper
|
||||
my @foo = map {
|
||||
- $_;
|
||||
} 1..10;
|
||||
\ @foo;
|
||||
|
||||
Putting a C<-> before a filter on a delimiter line, disables that filter.
|
||||
|
||||
=head2 Scalar vs List
|
||||
|
||||
Each filter can take either a scalar or a list as input, and will return
|
||||
either a scalar or a list. Since filters are chained together, it is
|
||||
important to learn which filters expect which kind of input and return which
|
||||
kind of output.
|
||||
|
||||
For example, consider the following filter list:
|
||||
|
||||
norm trim lines chomp array dumper eval
|
||||
|
||||
The data always starts out as a single scalar string. C<norm> takes a scalar
|
||||
and returns a scalar. C<trim> takes a list and returns a list, but a scalar is
|
||||
a valid list. C<lines> takes a scalar and returns a list. C<chomp> takes a
|
||||
list and returns a list. C<array> takes a list and returns a scalar (an
|
||||
anonymous array reference containing the list elements). C<dumper> takes a
|
||||
list and returns a scalar. C<eval> takes a scalar and creates a list.
|
||||
|
||||
A list of exactly one element works fine as input to a filter requiring a
|
||||
scalar, but any other list will cause an exception. A scalar in list context
|
||||
is considered a list of one element.
|
||||
|
||||
Data accessor methods for blocks will return a list of values when used in
|
||||
list context, and the first element of the list in scalar context. This is
|
||||
usually "the right thing", but be aware.
|
||||
|
||||
=head2 The Stock Filters
|
||||
|
||||
Test::Base comes with large set of stock filters. They are in the
|
||||
C<Test::Base::Filter> module. See L<Test::Base::Filter> for a listing and
|
||||
description of these filters.
|
||||
|
||||
=head2 Rolling Your Own Filters
|
||||
|
||||
Creating filter extensions is very simple. You can either write a I<function>
|
||||
in the C<main> namespace, or a I<method> in the C<Test::Base::Filter>
|
||||
namespace or a subclass of it. In either case the text and any extra arguments
|
||||
are passed in and you return whatever you want the new value to be.
|
||||
|
||||
Here is a self explanatory example:
|
||||
|
||||
use Test::Base;
|
||||
|
||||
filters 'foo', 'bar=xyz';
|
||||
|
||||
sub foo {
|
||||
transform(shift);
|
||||
}
|
||||
|
||||
sub Test::Base::Filter::bar {
|
||||
my $self = shift; # The Test::Base::Filter object
|
||||
my $data = shift;
|
||||
my $args = $self->current_arguments;
|
||||
my $current_block_object = $self->block;
|
||||
# transform $data in a barish manner
|
||||
return $data;
|
||||
}
|
||||
|
||||
If you use the method interface for a filter, you can access the block
|
||||
internals by calling the C<block> method on the filter object.
|
||||
|
||||
Normally you'll probably just use the functional interface, although all the
|
||||
builtin filters are methods.
|
||||
|
||||
Note that filters defined in the C<main> namespace can look like:
|
||||
|
||||
sub filter9 {
|
||||
s/foo/bar/;
|
||||
}
|
||||
|
||||
since Test::Base automatically munges the input string into $_ variable and
|
||||
checks the return value of the function to see if it looks like a number.
|
||||
If you must define a filter that returns just a single number, do it in a
|
||||
different namespace as a method. These filters don't allow the simplistic
|
||||
$_ munging.
|
||||
|
||||
=head1 OO
|
||||
|
||||
Test::Base has a nice functional interface for simple usage. Under the hood
|
||||
everything is object oriented. A default Test::Base object is created and all
|
||||
the functions are really just method calls on it.
|
||||
|
||||
This means if you need to get fancy, you can use all the object oriented stuff
|
||||
too. Just create new Test::Base objects and use the functions as methods.
|
||||
|
||||
use Test::Base;
|
||||
my $blocks1 = Test::Base->new;
|
||||
my $blocks2 = Test::Base->new;
|
||||
|
||||
$blocks1->delimiters(qw(!!! @@@))->spec_file('test1.txt');
|
||||
$blocks2->delimiters(qw(### $$$))->spec_string($test_data);
|
||||
|
||||
plan tests => $blocks1->blocks + $blocks2->blocks;
|
||||
|
||||
# ... etc
|
||||
|
||||
=head1 THE C<TEST::BASE::BLOCK> CLASS
|
||||
|
||||
In Test::Base, blocks are exposed as Test::Base::Block objects. This section
|
||||
lists the methods that can be called on a Test::Base::Block object. Of course,
|
||||
each data section name is also available as a method.
|
||||
|
||||
=over
|
||||
|
||||
=item C<name()>
|
||||
|
||||
This is the optional short description of a block, that is specified on the
|
||||
block separator line.
|
||||
|
||||
=item C<description()>
|
||||
|
||||
This is an optional long description of the block. It is the text taken from
|
||||
between the block separator and the first data section.
|
||||
|
||||
=item C<seq_num()>
|
||||
|
||||
Returns a sequence number for this block. Sequence numbers begin with 1.
|
||||
|
||||
=item C<blocks_object()>
|
||||
|
||||
Returns the Test::Base object that owns this block.
|
||||
|
||||
=item C<run_filters()>
|
||||
|
||||
Run the filters on the data sections of the blocks. You don't need to use this
|
||||
method unless you also used the C<filters_delay> function.
|
||||
|
||||
=item C<is_filtered()>
|
||||
|
||||
Returns true if filters have already been run for this block.
|
||||
|
||||
=item C<original_values()>
|
||||
|
||||
Returns a hash of the original, unfiltered values of each data section.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
One of the nicest things about Test::Base is that it is easy to subclass. This
|
||||
is very important, because in your personal project, you will likely want to
|
||||
extend Test::Base with your own filters and other reusable pieces of your test
|
||||
framework.
|
||||
|
||||
Here is an example of a subclass:
|
||||
|
||||
package MyTestStuff;
|
||||
use Test::Base -Base;
|
||||
|
||||
our @EXPORT = qw(some_func);
|
||||
|
||||
sub some_func {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
...
|
||||
}
|
||||
|
||||
package MyTestStuff::Block;
|
||||
use base 'Test::Base::Block';
|
||||
|
||||
sub desc {
|
||||
$self->description(@_);
|
||||
}
|
||||
|
||||
package MyTestStuff::Filter;
|
||||
use base 'Test::Base::Filter';
|
||||
|
||||
sub upper {
|
||||
$self->assert_scalar(@_);
|
||||
uc(shift);
|
||||
}
|
||||
|
||||
Note that you don't have to re-Export all the functions from Test::Base. That
|
||||
happens automatically, due to the powers of Spiffy.
|
||||
|
||||
The first line in C<some_func> allows it to be called as either a function or
|
||||
a method in the test code.
|
||||
|
||||
=head1 DISTRIBUTION SUPPORT
|
||||
|
||||
You might be thinking that you do not want to use Test::Base in you modules,
|
||||
because it adds an installation dependency. Fear not.
|
||||
L<Module::Install::TestBase> takes care of that.
|
||||
|
||||
Just write a Makefile.PL that looks something like this:
|
||||
|
||||
use inc::Module::Install;
|
||||
|
||||
name 'Foo';
|
||||
all_from 'lib/Foo.pm';
|
||||
|
||||
use_test_base;
|
||||
|
||||
WriteAll;
|
||||
|
||||
The line with C<use_test_base> will automatically bundle all the code the user
|
||||
needs to run Test::Base based tests.
|
||||
|
||||
=head1 OTHER COOL FEATURES
|
||||
|
||||
Test::Base automatically adds:
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
to all of your test scripts and Test::Base subclasses. A Spiffy feature
|
||||
indeed.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
This module started its life with the horrible and ridicule inducing name
|
||||
C<Test::Chunks>. It was renamed to C<Test::Base> with the hope that it would
|
||||
be seen for the very useful module that it has become. If you are switching
|
||||
from C<Test::Chunks> to C<Test::Base>, simply substitute the concept and usage
|
||||
of C<chunks> to C<blocks>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ingy döt Net <ingy@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005-2018. Ingy döt Net.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
See L<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=cut
|
||||
338
database/perl/vendor/lib/Test/Base/Filter.pm
vendored
Normal file
338
database/perl/vendor/lib/Test/Base/Filter.pm
vendored
Normal file
@@ -0,0 +1,338 @@
|
||||
#===============================================================================
|
||||
# This is the default class for handling Test::Base data filtering.
|
||||
#===============================================================================
|
||||
package Test::Base::Filter;
|
||||
use Spiffy -Base;
|
||||
use Spiffy ':XXX';
|
||||
|
||||
field 'current_block';
|
||||
|
||||
our $arguments;
|
||||
sub current_arguments {
|
||||
return undef unless defined $arguments;
|
||||
my $args = $arguments;
|
||||
$args =~ s/(\\s)/ /g;
|
||||
$args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
|
||||
return $args;
|
||||
}
|
||||
|
||||
sub assert_scalar {
|
||||
return if @_ == 1;
|
||||
require Carp;
|
||||
my $filter = (caller(1))[3];
|
||||
$filter =~ s/.*:://;
|
||||
Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
|
||||
}
|
||||
|
||||
sub _apply_deepest {
|
||||
my $method = shift;
|
||||
return () unless @_;
|
||||
if (ref $_[0] eq 'ARRAY') {
|
||||
for my $aref (@_) {
|
||||
@$aref = $self->_apply_deepest($method, @$aref);
|
||||
}
|
||||
return @_;
|
||||
}
|
||||
$self->$method(@_);
|
||||
}
|
||||
|
||||
sub _split_array {
|
||||
map {
|
||||
[$self->split($_)];
|
||||
} @_;
|
||||
}
|
||||
|
||||
sub _peel_deepest {
|
||||
return () unless @_;
|
||||
if (ref $_[0] eq 'ARRAY') {
|
||||
if (ref $_[0]->[0] eq 'ARRAY') {
|
||||
for my $aref (@_) {
|
||||
@$aref = $self->_peel_deepest(@$aref);
|
||||
}
|
||||
return @_;
|
||||
}
|
||||
return map { $_->[0] } @_;
|
||||
}
|
||||
return @_;
|
||||
}
|
||||
|
||||
#===============================================================================
|
||||
# these filters work on the leaves of nested arrays
|
||||
#===============================================================================
|
||||
sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
|
||||
sub Reverse { $self->_apply_deepest(reverse => @_) }
|
||||
sub Split { $self->_apply_deepest(_split_array => @_) }
|
||||
sub Sort { $self->_apply_deepest(sort => @_) }
|
||||
|
||||
|
||||
sub append {
|
||||
my $suffix = $self->current_arguments;
|
||||
map { $_ . $suffix } @_;
|
||||
}
|
||||
|
||||
sub array {
|
||||
return [@_];
|
||||
}
|
||||
|
||||
sub base64_decode {
|
||||
$self->assert_scalar(@_);
|
||||
require MIME::Base64;
|
||||
MIME::Base64::decode_base64(shift);
|
||||
}
|
||||
|
||||
sub base64_encode {
|
||||
$self->assert_scalar(@_);
|
||||
require MIME::Base64;
|
||||
MIME::Base64::encode_base64(shift);
|
||||
}
|
||||
|
||||
sub chomp {
|
||||
map { CORE::chomp; $_ } @_;
|
||||
}
|
||||
|
||||
sub chop {
|
||||
map { CORE::chop; $_ } @_;
|
||||
}
|
||||
|
||||
sub dumper {
|
||||
no warnings 'once';
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
local $Data::Dumper::Indent = 1;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
Data::Dumper::Dumper(@_);
|
||||
}
|
||||
|
||||
sub escape {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
$text =~ s/(\\.)/eval "qq{$1}"/ge;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub eval {
|
||||
$self->assert_scalar(@_);
|
||||
my @return = CORE::eval(shift);
|
||||
return $@ if $@;
|
||||
return @return;
|
||||
}
|
||||
|
||||
sub eval_all {
|
||||
$self->assert_scalar(@_);
|
||||
my $out = '';
|
||||
my $err = '';
|
||||
Test::Base::tie_output(*STDOUT, $out);
|
||||
Test::Base::tie_output(*STDERR, $err);
|
||||
my $return = CORE::eval(shift);
|
||||
no warnings;
|
||||
untie *STDOUT;
|
||||
untie *STDERR;
|
||||
return $return, $@, $out, $err;
|
||||
}
|
||||
|
||||
sub eval_stderr {
|
||||
$self->assert_scalar(@_);
|
||||
my $output = '';
|
||||
Test::Base::tie_output(*STDERR, $output);
|
||||
CORE::eval(shift);
|
||||
no warnings;
|
||||
untie *STDERR;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub eval_stdout {
|
||||
$self->assert_scalar(@_);
|
||||
my $output = '';
|
||||
Test::Base::tie_output(*STDOUT, $output);
|
||||
CORE::eval(shift);
|
||||
no warnings;
|
||||
untie *STDOUT;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub exec_perl_stdout {
|
||||
my $tmpfile = "/tmp/test-blocks-$$";
|
||||
$self->_write_to($tmpfile, @_);
|
||||
open my $execution, "$^X $tmpfile 2>&1 |"
|
||||
or die "Couldn't open subprocess: $!\n";
|
||||
local $/;
|
||||
my $output = <$execution>;
|
||||
close $execution;
|
||||
unlink($tmpfile)
|
||||
or die "Couldn't unlink $tmpfile: $!\n";
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub flatten {
|
||||
$self->assert_scalar(@_);
|
||||
my $ref = shift;
|
||||
if (ref($ref) eq 'HASH') {
|
||||
return map {
|
||||
($_, $ref->{$_});
|
||||
} sort keys %$ref;
|
||||
}
|
||||
if (ref($ref) eq 'ARRAY') {
|
||||
return @$ref;
|
||||
}
|
||||
die "Can only flatten a hash or array ref";
|
||||
}
|
||||
|
||||
sub get_url {
|
||||
$self->assert_scalar(@_);
|
||||
my $url = shift;
|
||||
CORE::chomp($url);
|
||||
require LWP::Simple;
|
||||
LWP::Simple::get($url);
|
||||
}
|
||||
|
||||
sub hash {
|
||||
return +{ @_ };
|
||||
}
|
||||
|
||||
sub head {
|
||||
my $size = $self->current_arguments || 1;
|
||||
return splice(@_, 0, $size);
|
||||
}
|
||||
|
||||
sub join {
|
||||
my $string = $self->current_arguments;
|
||||
$string = '' unless defined $string;
|
||||
CORE::join $string, @_;
|
||||
}
|
||||
|
||||
sub lines {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
return () unless length $text;
|
||||
my @lines = ($text =~ /^(.*\n?)/gm);
|
||||
return @lines;
|
||||
}
|
||||
|
||||
sub norm {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
$text = '' unless defined $text;
|
||||
$text =~ s/\015\012/\n/g;
|
||||
$text =~ s/\r/\n/g;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub prepend {
|
||||
my $prefix = $self->current_arguments;
|
||||
map { $prefix . $_ } @_;
|
||||
}
|
||||
|
||||
sub read_file {
|
||||
$self->assert_scalar(@_);
|
||||
my $file = shift;
|
||||
CORE::chomp $file;
|
||||
open my $fh, $file
|
||||
or die "Can't open '$file' for input:\n$!";
|
||||
CORE::join '', <$fh>;
|
||||
}
|
||||
|
||||
sub regexp {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
my $flags = $self->current_arguments;
|
||||
if ($text =~ /\n.*?\n/s) {
|
||||
$flags = 'xism'
|
||||
unless defined $flags;
|
||||
}
|
||||
else {
|
||||
CORE::chomp($text);
|
||||
}
|
||||
$flags ||= '';
|
||||
my $regexp = eval "qr{$text}$flags";
|
||||
die $@ if $@;
|
||||
return $regexp;
|
||||
}
|
||||
|
||||
sub reverse {
|
||||
CORE::reverse(@_);
|
||||
}
|
||||
|
||||
sub slice {
|
||||
die "Invalid args for slice"
|
||||
unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
|
||||
my ($x, $y) = ($1, $2);
|
||||
$y = $x if not defined $y;
|
||||
die "Invalid args for slice"
|
||||
if $x > $y;
|
||||
return splice(@_, $x, 1 + $y - $x);
|
||||
}
|
||||
|
||||
sub sort {
|
||||
CORE::sort(@_);
|
||||
}
|
||||
|
||||
sub split {
|
||||
$self->assert_scalar(@_);
|
||||
my $separator = $self->current_arguments;
|
||||
if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
|
||||
my $regexp = $1;
|
||||
$separator = qr{$regexp};
|
||||
}
|
||||
$separator = qr/\s+/ unless $separator;
|
||||
CORE::split $separator, shift;
|
||||
}
|
||||
|
||||
sub strict {
|
||||
$self->assert_scalar(@_);
|
||||
<<'...' . shift;
|
||||
use strict;
|
||||
use warnings;
|
||||
...
|
||||
}
|
||||
|
||||
sub tail {
|
||||
my $size = $self->current_arguments || 1;
|
||||
return splice(@_, @_ - $size, $size);
|
||||
}
|
||||
|
||||
sub trim {
|
||||
map {
|
||||
s/\A([ \t]*\n)+//;
|
||||
s/(?<=\n)\s*\z//g;
|
||||
$_;
|
||||
} @_;
|
||||
}
|
||||
|
||||
sub unchomp {
|
||||
map { $_ . "\n" } @_;
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my $file = $self->current_arguments
|
||||
or die "No file specified for write_file filter";
|
||||
if ($file =~ /(.*)[\\\/]/) {
|
||||
my $dir = $1;
|
||||
if (not -e $dir) {
|
||||
require File::Path;
|
||||
File::Path::mkpath($dir)
|
||||
or die "Can't create $dir";
|
||||
}
|
||||
}
|
||||
open my $fh, ">$file"
|
||||
or die "Can't open '$file' for output\n:$!";
|
||||
print $fh @_;
|
||||
close $fh;
|
||||
return $file;
|
||||
}
|
||||
|
||||
sub yaml {
|
||||
$self->assert_scalar(@_);
|
||||
require YAML;
|
||||
return YAML::Load(shift);
|
||||
}
|
||||
|
||||
sub _write_to {
|
||||
my $filename = shift;
|
||||
open my $script, ">$filename"
|
||||
or die "Couldn't open $filename: $!\n";
|
||||
print $script @_;
|
||||
close $script
|
||||
or die "Couldn't close $filename: $!\n";
|
||||
}
|
||||
|
||||
1;
|
||||
309
database/perl/vendor/lib/Test/Base/Filter.pod
vendored
Normal file
309
database/perl/vendor/lib/Test/Base/Filter.pod
vendored
Normal file
@@ -0,0 +1,309 @@
|
||||
=pod
|
||||
|
||||
=for comment
|
||||
DO NOT EDIT. This Pod was generated by Swim v0.1.46.
|
||||
See http://github.com/ingydotnet/swim-pm#readme
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Base::Filter - Default Filter Class for Test::Base
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyTestSuite;
|
||||
use Test::Base -Base;
|
||||
|
||||
... reusable testing code ...
|
||||
|
||||
package MyTestSuite::Filter;
|
||||
use Test::Base::Filter -Base;
|
||||
|
||||
sub my_filter1 {
|
||||
...
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Filters are the key to writing effective data driven tests with Test::Base.
|
||||
Test::Base::Filter is a class containing a large default set of generic
|
||||
filters. You can easily subclass it to add/override functionality.
|
||||
|
||||
=head1 FILTERS
|
||||
|
||||
This is a list of the default stock filters (in alphabetic order):
|
||||
|
||||
=over
|
||||
|
||||
=item C<append>
|
||||
|
||||
list => list
|
||||
|
||||
Append a string to each element of a list.
|
||||
|
||||
--- numbers lines chomp append=-#\n join
|
||||
one
|
||||
two
|
||||
three
|
||||
|
||||
=item C<array>
|
||||
|
||||
list => scalar
|
||||
|
||||
Turn a list of values into an anonymous array reference.
|
||||
|
||||
=item C<base64_decode>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Decode base64 data. Useful for binary tests.
|
||||
|
||||
=item C<base64_encode>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Encode base64 data. Useful for binary tests.
|
||||
|
||||
=item C<chomp>
|
||||
|
||||
list => list
|
||||
|
||||
Remove the final newline from each string value in a list.
|
||||
|
||||
=item C<chop>
|
||||
|
||||
|
||||
=back
|
||||
|
||||
list => list
|
||||
|
||||
Remove the final char from each string value in a list.
|
||||
|
||||
=over
|
||||
|
||||
=item C<dumper>
|
||||
|
||||
scalar => list
|
||||
|
||||
Take a data structure (presumably from another filter like eval) and use
|
||||
Data::Dumper to dump it in a canonical fashion.
|
||||
|
||||
=item C<escape>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Unescape all backslash escaped chars.
|
||||
|
||||
=item C<eval>
|
||||
|
||||
scalar => list
|
||||
|
||||
Run Perl's C<eval> command against the data and use the returned value
|
||||
as the data.
|
||||
|
||||
=item C<eval_all>
|
||||
|
||||
scalar => list
|
||||
|
||||
Run Perl's C<eval> command against the data and return a list of 4 values:
|
||||
|
||||
1) The return value
|
||||
2) The error in $@
|
||||
3) Captured STDOUT
|
||||
4) Captured STDERR
|
||||
|
||||
=item C<eval_stderr>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Run Perl's C<eval> command against the data and return the captured STDERR.
|
||||
|
||||
=item C<eval_stdout>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Run Perl's C<eval> command against the data and return the captured STDOUT.
|
||||
|
||||
=item C<exec_perl_stdout>
|
||||
|
||||
list => scalar
|
||||
|
||||
Input Perl code is written to a temp file and run. STDOUT is captured
|
||||
and returned.
|
||||
|
||||
=item C<flatten>
|
||||
|
||||
scalar => list
|
||||
|
||||
Takes a hash or array ref and flattens it to a list.
|
||||
|
||||
=item C<get_url>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
The text is chomped and considered to be a url. Then LWP::Simple::get is used
|
||||
to fetch the contents of the url.
|
||||
|
||||
=item C<hash>
|
||||
|
||||
list => scalar
|
||||
|
||||
Turn a list of key/value pairs into an anonymous hash reference.
|
||||
|
||||
=item C<head[=number]>
|
||||
|
||||
list => list
|
||||
|
||||
Takes a list and returns a number of the elements from the front of it. The
|
||||
default number is one.
|
||||
|
||||
=item C<join>
|
||||
|
||||
list => scalar
|
||||
|
||||
Join a list of strings into a scalar.
|
||||
|
||||
=item C<Join>
|
||||
|
||||
Join the list of strings inside a list of array refs and return the strings in
|
||||
place of the array refs.
|
||||
|
||||
=item C<lines>
|
||||
|
||||
scalar => list
|
||||
|
||||
Break the data into an anonymous array of lines. Each line (except
|
||||
possibly the last one if the C<chomp> filter came first) will have a
|
||||
newline at the end.
|
||||
|
||||
=item C<norm>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Normalize the data. Change non-Unix line endings to Unix line endings.
|
||||
|
||||
=item C<prepend=string>
|
||||
|
||||
list => list
|
||||
|
||||
Prepend a string onto each of a list of strings.
|
||||
|
||||
=item C<read_file>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Read the file named by the current content and return the file's content.
|
||||
|
||||
=item C<regexp[=xism]>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
The C<regexp> filter will turn your data section into a regular expression
|
||||
object. You can pass in extra flags after an equals sign.
|
||||
|
||||
If the text contains more than one line and no flags are specified, then the
|
||||
'xism' flags are assumed.
|
||||
|
||||
=item C<reverse>
|
||||
|
||||
list => list
|
||||
|
||||
Reverse the elements of a list.
|
||||
|
||||
=item C<Reverse>
|
||||
|
||||
list => list
|
||||
|
||||
Reverse the list of strings inside a list of array refs.
|
||||
|
||||
=item C<slice=x[,y]>
|
||||
|
||||
list => list
|
||||
|
||||
Returns the element number x through element number y of a list.
|
||||
|
||||
=item C<sort>
|
||||
|
||||
list => list
|
||||
|
||||
Sorts the elements of a list in character sort order.
|
||||
|
||||
=item C<Sort>
|
||||
|
||||
list => list
|
||||
|
||||
Sort the list of strings inside a list of array refs.
|
||||
|
||||
=item C<split[=string|pattern]>
|
||||
|
||||
scalar => list
|
||||
|
||||
Split a string in into a list. Takes a optional string or regexp as a
|
||||
parameter. Defaults to I<s+>. Same as Perl C<split>.
|
||||
|
||||
=item C<Split[=string|pattern]>
|
||||
|
||||
list => list
|
||||
|
||||
Split each of a list of strings and turn them into array refs.
|
||||
|
||||
=item C<strict>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Prepend the string:
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
to the block's text.
|
||||
|
||||
=item C<tail[=number]>
|
||||
|
||||
list => list
|
||||
|
||||
Return a number of elements from the end of a list. The default number is one.
|
||||
|
||||
=item C<trim>
|
||||
|
||||
list => list
|
||||
|
||||
Remove extra blank lines from the beginning and end of the data. This allows
|
||||
you to visually separate your test data with blank lines.
|
||||
|
||||
=item C<unchomp>
|
||||
|
||||
list => list
|
||||
|
||||
Add a newline to each string value in a list.
|
||||
|
||||
=item C<write_file[=filename]>
|
||||
|
||||
scalar => scalar
|
||||
|
||||
Write the content of the section to the named file. Return the filename.
|
||||
|
||||
=item C<yaml>
|
||||
|
||||
scalar => list
|
||||
|
||||
Apply the YAML::Load function to the data block and use the resultant
|
||||
structure. Requires YAML.pm.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ingy döt Net <ingy@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005-2018. Ingy döt Net. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
See L<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=cut
|
||||
332
database/perl/vendor/lib/Test/CleanNamespaces.pm
vendored
Normal file
332
database/perl/vendor/lib/Test/CleanNamespaces.pm
vendored
Normal file
@@ -0,0 +1,332 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
package Test::CleanNamespaces; # git description: v0.23-5-gf8e88b1
|
||||
# ABSTRACT: Check for uncleaned imports
|
||||
# KEYWORDS: testing namespaces clean dirty imports exports subroutines methods
|
||||
|
||||
our $VERSION = '0.24';
|
||||
|
||||
use Module::Runtime ();
|
||||
use Sub::Identify ();
|
||||
use Package::Stash 0.14;
|
||||
use Test::Builder;
|
||||
use File::Find ();
|
||||
use File::Spec;
|
||||
|
||||
use Exporter 5.57 'import';
|
||||
our @EXPORT = qw(namespaces_clean all_namespaces_clean);
|
||||
|
||||
#pod =head1 SYNOPSIS
|
||||
#pod
|
||||
#pod use strict;
|
||||
#pod use warnings;
|
||||
#pod use Test::CleanNamespaces;
|
||||
#pod
|
||||
#pod all_namespaces_clean;
|
||||
#pod
|
||||
#pod =head1 DESCRIPTION
|
||||
#pod
|
||||
#pod This module lets you check your module's namespaces for imported functions you
|
||||
#pod might have forgotten to remove with L<namespace::autoclean> or
|
||||
#pod L<namespace::clean> and are therefore available to be called as methods, which
|
||||
#pod usually isn't want you want.
|
||||
#pod
|
||||
#pod =head1 FUNCTIONS
|
||||
#pod
|
||||
#pod All functions are exported by default.
|
||||
#pod
|
||||
#pod =head2 namespaces_clean
|
||||
#pod
|
||||
#pod namespaces_clean('YourModule', 'AnotherModule');
|
||||
#pod
|
||||
#pod Tests every specified namespace for uncleaned imports. If the module couldn't
|
||||
#pod be loaded it will be skipped.
|
||||
#pod
|
||||
#pod =head2 all_namespaces_clean
|
||||
#pod
|
||||
#pod all_namespaces_clean;
|
||||
#pod
|
||||
#pod Runs L</namespaces_clean> for all modules in your distribution.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub namespaces_clean {
|
||||
my (@namespaces) = @_;
|
||||
local $@;
|
||||
my $builder = builder();
|
||||
|
||||
my $result = 1;
|
||||
for my $ns (@namespaces) {
|
||||
unless (eval { Module::Runtime::require_module($ns); 1 }) {
|
||||
$builder->skip("failed to load ${ns}: $@");
|
||||
next;
|
||||
}
|
||||
|
||||
my $imports = _remaining_imports($ns);
|
||||
|
||||
my $ok = $builder->ok(!keys(%$imports), "${ns} contains no imported functions");
|
||||
$ok or $builder->diag($builder->explain('remaining imports: ' => $imports));
|
||||
|
||||
$result &&= $ok;
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub all_namespaces_clean {
|
||||
my @modules = find_modules(@_);
|
||||
builder()->plan(tests => scalar @modules);
|
||||
namespaces_clean(@modules);
|
||||
}
|
||||
|
||||
# given a package name, returns a hashref of all remaining imports
|
||||
sub _remaining_imports {
|
||||
my $ns = shift;
|
||||
|
||||
my $symbols = Package::Stash->new($ns)->get_all_symbols('CODE');
|
||||
my @imports;
|
||||
|
||||
my $meta;
|
||||
if ($INC{ Module::Runtime::module_notional_filename('Class::MOP') }
|
||||
and $meta = Class::MOP::class_of($ns)
|
||||
and $meta->can('get_method_list'))
|
||||
{
|
||||
my %subs = %$symbols;
|
||||
delete @subs{ $meta->get_method_list };
|
||||
@imports = keys %subs;
|
||||
}
|
||||
elsif ($INC{ Module::Runtime::module_notional_filename('Mouse::Util') }
|
||||
and Mouse::Util->can('class_of') and $meta = Mouse::Util::class_of($ns))
|
||||
{
|
||||
warn 'Mouse class detected - chance of false negatives is high!';
|
||||
|
||||
my %subs = %$symbols;
|
||||
# ugh, this returns far more than the true list of methods
|
||||
delete @subs{ $meta->get_method_list };
|
||||
@imports = keys %subs;
|
||||
}
|
||||
else
|
||||
{
|
||||
@imports = grep {
|
||||
my $stash = Sub::Identify::stash_name($symbols->{$_});
|
||||
$stash ne $ns
|
||||
and $stash ne 'Role::Tiny'
|
||||
and not eval { require Role::Tiny; Role::Tiny->is_role($stash) }
|
||||
} keys %$symbols;
|
||||
}
|
||||
|
||||
my %imports; @imports{@imports} = map { Sub::Identify::sub_fullname($symbols->{$_}) } @imports;
|
||||
|
||||
# these subs are special-cased - they are often provided by other
|
||||
# modules, but cannot be wrapped with Sub::Name as the call stack
|
||||
# is important
|
||||
delete @imports{qw(import unimport)};
|
||||
|
||||
my @overloads = grep { $imports{$_} eq 'overload::nil' || $imports{$_} eq 'overload::_nil' } keys %imports;
|
||||
delete @imports{@overloads} if @overloads;
|
||||
|
||||
if ("$]" < 5.020)
|
||||
{
|
||||
# < haarg> 5.10+ allows sticking a readonly scalar ref directly in the symbol table, rather than a glob. when auto-promoted to a sub, it will have the correct name.
|
||||
# < haarg> but that only works if the symbol table entry is empty
|
||||
# < haarg> if it exists, it has to use the *$const = sub () { $val } method, so the name is __ANON__
|
||||
# < haarg> newer versions don't use that method
|
||||
# < haarg> rather, newer versions of constant.pm don't use that method
|
||||
# < haarg> and then the name ends up being YourPackage::__ANON__
|
||||
my @constants = grep { $imports{$_} eq 'constant::__ANON__' } keys %imports;
|
||||
delete @imports{@constants} if @constants;
|
||||
}
|
||||
|
||||
return \%imports;
|
||||
}
|
||||
|
||||
#pod =head2 find_modules
|
||||
#pod
|
||||
#pod my @modules = Test::CleanNamespaces->find_modules;
|
||||
#pod
|
||||
#pod Returns a list of modules in the current distribution. It'll search in
|
||||
#pod C<blib/>, if it exists. C<lib/> will be searched otherwise.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub find_modules {
|
||||
my @modules;
|
||||
for my $top (-e 'blib' ? ('blib/lib', 'blib/arch') : 'lib') {
|
||||
File::Find::find({
|
||||
no_chdir => 1,
|
||||
wanted => sub {
|
||||
my $file = $_;
|
||||
return
|
||||
unless $file =~ s/\.pm$//;
|
||||
push @modules, join '::' => File::Spec->splitdir(
|
||||
File::Spec->abs2rel(File::Spec->rel2abs($file, '.'), $top)
|
||||
);
|
||||
},
|
||||
}, $top);
|
||||
}
|
||||
return @modules;
|
||||
}
|
||||
|
||||
#pod =head2 builder
|
||||
#pod
|
||||
#pod my $builder = Test::CleanNamespaces->builder;
|
||||
#pod
|
||||
#pod Returns the C<Test::Builder> used by the test functions.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
{
|
||||
my $Test = Test::Builder->new;
|
||||
sub builder { $Test }
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::CleanNamespaces - Check for uncleaned imports
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.24
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Test::CleanNamespaces;
|
||||
|
||||
all_namespaces_clean;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module lets you check your module's namespaces for imported functions you
|
||||
might have forgotten to remove with L<namespace::autoclean> or
|
||||
L<namespace::clean> and are therefore available to be called as methods, which
|
||||
usually isn't want you want.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
All functions are exported by default.
|
||||
|
||||
=head2 namespaces_clean
|
||||
|
||||
namespaces_clean('YourModule', 'AnotherModule');
|
||||
|
||||
Tests every specified namespace for uncleaned imports. If the module couldn't
|
||||
be loaded it will be skipped.
|
||||
|
||||
=head2 all_namespaces_clean
|
||||
|
||||
all_namespaces_clean;
|
||||
|
||||
Runs L</namespaces_clean> for all modules in your distribution.
|
||||
|
||||
=head2 find_modules
|
||||
|
||||
my @modules = Test::CleanNamespaces->find_modules;
|
||||
|
||||
Returns a list of modules in the current distribution. It'll search in
|
||||
C<blib/>, if it exists. C<lib/> will be searched otherwise.
|
||||
|
||||
=head2 builder
|
||||
|
||||
my $builder = Test::CleanNamespaces->builder;
|
||||
|
||||
Returns the C<Test::Builder> used by the test functions.
|
||||
|
||||
=head1 KNOWN ISSUES
|
||||
|
||||
Uncleaned imports from L<Mouse> classes are incompletely detected, due to its
|
||||
lack of ability to return the correct method list -- it assumes that all subs
|
||||
are meant to be callable as methods unless they originated from (were imported
|
||||
by) one of: L<Mouse>, L<Mouse::Role>, L<Mouse::Util>,
|
||||
L<Mouse::Util::TypeConstraints>, L<Carp>, L<Scalar::Util>, or L<List::Util>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
L<namespace::clean>
|
||||
|
||||
=item *
|
||||
|
||||
L<namespace::autoclean>
|
||||
|
||||
=item *
|
||||
|
||||
L<namespace::sweep>
|
||||
|
||||
=item *
|
||||
|
||||
L<Sub::Exporter::ForMethods>
|
||||
|
||||
=item *
|
||||
|
||||
L<Test::API>
|
||||
|
||||
=item *
|
||||
|
||||
L<Sub::Name>
|
||||
|
||||
=item *
|
||||
|
||||
L<Sub::Install>
|
||||
|
||||
=item *
|
||||
|
||||
L<MooseX::MarkAsMethods>
|
||||
|
||||
=item *
|
||||
|
||||
L<Dist::Zilla::Plugin::Test::CleanNamespaces>
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Test-CleanNamespaces>
|
||||
(or L<bug-Test-CleanNamespaces@rt.cpan.org|mailto:bug-Test-CleanNamespaces@rt.cpan.org>).
|
||||
|
||||
There is also a mailing list available for users of this distribution, at
|
||||
L<http://lists.perl.org/list/perl-qa.html>.
|
||||
|
||||
There is also an irc channel available for users of this distribution, at
|
||||
L<C<#perl> on C<irc.perl.org>|irc://irc.perl.org/#perl-qa>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Karen Etheridge Graham Knop
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Graham Knop <haarg@haarg.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENCE
|
||||
|
||||
This software is copyright (c) 2009 by Florian Ragwitz.
|
||||
|
||||
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
|
||||
591
database/perl/vendor/lib/Test/Differences.pm
vendored
Normal file
591
database/perl/vendor/lib/Test/Differences.pm
vendored
Normal file
@@ -0,0 +1,591 @@
|
||||
package Test::Differences;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Differences - Test strings and data structures and show differences if not ok
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test; ## Or use Test::More
|
||||
use Test::Differences;
|
||||
|
||||
eq_or_diff $got, "a\nb\nc\n", "testing strings";
|
||||
eq_or_diff \@got, [qw( a b c )], "testing arrays";
|
||||
|
||||
## Passing options:
|
||||
eq_or_diff $got, $expected, $name, { context => 300 }; ## options
|
||||
|
||||
## Using with DBI-like data structures
|
||||
|
||||
use DBI;
|
||||
|
||||
... open connection & prepare statement and @expected_... here...
|
||||
|
||||
eq_or_diff $sth->fetchall_arrayref, \@expected_arrays "testing DBI arrays";
|
||||
eq_or_diff $sth->fetchall_hashref, \@expected_hashes, "testing DBI hashes";
|
||||
|
||||
## To force textual or data line numbering (text lines are numbered 1..):
|
||||
eq_or_diff_text ...;
|
||||
eq_or_diff_data ...;
|
||||
|
||||
=head1 EXPORT
|
||||
|
||||
This module exports three test functions and four diff-style functions:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Test functions
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<eq_or_diff>
|
||||
|
||||
=item * C<eq_or_diff_data>
|
||||
|
||||
=item * C<eq_or_diff_text>
|
||||
|
||||
=back
|
||||
|
||||
=item * Diff style functions
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<table_diff> (the default)
|
||||
|
||||
=item * C<unified_diff>
|
||||
|
||||
=item * C<oldstyle_diff>
|
||||
|
||||
=item * C<context_diff>
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When the code you're testing returns multiple lines, records or data
|
||||
structures and they're just plain wrong, an equivalent to the Unix
|
||||
C<diff> utility may be just what's needed. Here's output from an
|
||||
example test script that checks two text documents and then two
|
||||
(trivial) data structures:
|
||||
|
||||
t/99example....1..3
|
||||
not ok 1 - differences in text
|
||||
# Failed test ((eval 2) at line 14)
|
||||
# +---+----------------+----------------+
|
||||
# | Ln|Got |Expected |
|
||||
# +---+----------------+----------------+
|
||||
# | 1|this is line 1 |this is line 1 |
|
||||
# * 2|this is line 2 |this is line b *
|
||||
# | 3|this is line 3 |this is line 3 |
|
||||
# +---+----------------+----------------+
|
||||
not ok 2 - differences in whitespace
|
||||
# Failed test ((eval 2) at line 20)
|
||||
# +---+------------------+------------------+
|
||||
# | Ln|Got |Expected |
|
||||
# +---+------------------+------------------+
|
||||
# | 1| indented | indented |
|
||||
# * 2| indented |\tindented *
|
||||
# | 3| indented | indented |
|
||||
# +---+------------------+------------------+
|
||||
not ok 3
|
||||
# Failed test ((eval 2) at line 22)
|
||||
# +----+-------------------------------------+----------------------------+
|
||||
# | Elt|Got |Expected |
|
||||
# +----+-------------------------------------+----------------------------+
|
||||
# * 0|bless( [ |[ *
|
||||
# * 1| 'Move along, nothing to see here' | 'Dry, humorless message' *
|
||||
# * 2|], 'Test::Builder' ) |] *
|
||||
# +----+-------------------------------------+----------------------------+
|
||||
# Looks like you failed 3 tests of 3.
|
||||
|
||||
eq_or_diff_...() compares two strings or (limited) data structures and
|
||||
either emits an ok indication or a side-by-side diff. Test::Differences
|
||||
is designed to be used with Test.pm and with Test::Simple, Test::More,
|
||||
and other Test::Builder based testing modules. As the SYNOPSIS shows,
|
||||
another testing module must be used as the basis for your test suite.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
The options to C<eq_or_diff> give some fine-grained control over the output.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<context>
|
||||
|
||||
This allows you to control the amount of context shown:
|
||||
|
||||
eq_or_diff $got, $expected, $name, { context => 50000 };
|
||||
|
||||
will show you lots and lots of context. Normally, eq_or_diff() uses
|
||||
some heuristics to determine whether to show 3 lines of context (like
|
||||
a normal unified diff) or 25 lines.
|
||||
|
||||
=item * C<data_type>
|
||||
|
||||
C<text> or C<data>. See C<eq_or_diff_text> and C<eq_or_diff_data> to
|
||||
understand this. You can usually ignore this.
|
||||
|
||||
=item * C<Sortkeys>
|
||||
|
||||
If passed, whatever value is added is used as the argument for L<Data::Dumper>
|
||||
Sortkeys option. See the L<Data::Dumper> docs to understand how you can
|
||||
control the Sortkeys behavior.
|
||||
|
||||
=item * C<filename_a> and C<filename_b>
|
||||
|
||||
The column headers to use in the output. They default to 'Got' and 'Expected'.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIFF STYLES
|
||||
|
||||
For extremely long strings, a table diff can wrap on your screen and be hard
|
||||
to read. If you are comfortable with different diff formats, you can switch
|
||||
to a format more suitable for your data. These are the four formats supported
|
||||
by the L<Text::Diff> module and are set with the following functions:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<table_diff> (the default)
|
||||
|
||||
=item * C<unified_diff>
|
||||
|
||||
=item * C<oldstyle_diff>
|
||||
|
||||
=item * C<context_diff>
|
||||
|
||||
=back
|
||||
|
||||
You can run the following to understand the different diff output styles:
|
||||
|
||||
use Test::More 'no_plan';
|
||||
use Test::Differences;
|
||||
|
||||
my $long_string = join '' => 1..40;
|
||||
|
||||
TODO: {
|
||||
local $TODO = 'Testing diff styles';
|
||||
|
||||
# this is the default and does not need to explicitly set unless you need
|
||||
# to reset it back from another diff type
|
||||
table_diff;
|
||||
eq_or_diff $long_string, "-$long_string", 'table diff';
|
||||
|
||||
unified_diff;
|
||||
eq_or_diff $long_string, "-$long_string", 'unified diff';
|
||||
|
||||
context_diff;
|
||||
eq_or_diff $long_string, "-$long_string", 'context diff';
|
||||
|
||||
oldstyle_diff;
|
||||
eq_or_diff $long_string, "-$long_string", 'oldstyle diff';
|
||||
}
|
||||
|
||||
=head1 UNICODE
|
||||
|
||||
Generally you'll find that the following test output is disappointing.
|
||||
|
||||
use Test::Differences;
|
||||
|
||||
my $want = { 'Traditional Chinese' => '中國' };
|
||||
my $have = { 'Traditional Chinese' => '中国' };
|
||||
|
||||
eq_or_diff $have, $want, 'Unicode, baby';
|
||||
|
||||
The output looks like this:
|
||||
|
||||
# Failed test 'Unicode, baby'
|
||||
# at t/unicode.t line 12.
|
||||
# +----+----------------------------+----------------------------+
|
||||
# | Elt|Got |Expected |
|
||||
# +----+----------------------------+----------------------------+
|
||||
# | 0|'Traditional Chinese' |'Traditional Chinese' |
|
||||
# * 1|'\xe4\xb8\xad\xe5\x9b\xbd' |'\xe4\xb8\xad\xe5\x9c\x8b' *
|
||||
# +----+----------------------------+----------------------------+
|
||||
# Looks like you failed 1 test of 1.
|
||||
Dubious, test returned 1 (wstat 256, 0x100)
|
||||
|
||||
This is generally not helpful and someone points out that you didn't declare
|
||||
your test program as being utf8, so you do that:
|
||||
|
||||
use Test::Differences;
|
||||
use utf8;
|
||||
|
||||
my $want = { 'Traditional Chinese' => '中國' };
|
||||
my $have = { 'Traditional Chinese' => '中国' };
|
||||
|
||||
eq_or_diff $have, $want, 'Unicode, baby';
|
||||
|
||||
|
||||
Here's what you get:
|
||||
|
||||
# Failed test 'Unicode, baby'
|
||||
# at t/unicode.t line 12.
|
||||
# +----+-----------------------+-----------------------+
|
||||
# | Elt|Got |Expected |
|
||||
# +----+-----------------------+-----------------------+
|
||||
# | 0|'Traditional Chinese' |'Traditional Chinese' |
|
||||
# * 1|'\x{4e2d}\x{56fd}' |'\x{4e2d}\x{570b}' *
|
||||
# +----+-----------------------+-----------------------+
|
||||
# Looks like you failed 1 test of 1.
|
||||
Dubious, test returned 1 (wstat 256, 0x100)
|
||||
Failed 1/1 subtests
|
||||
|
||||
That's better, but still awful. However, if you have C<Text::Diff> 0.40 or
|
||||
higher installed, you can add this to your code:
|
||||
|
||||
BEGIN { $ENV{DIFF_OUTPUT_UNICODE} = 1 }
|
||||
|
||||
Make sure you do this I<before> you load L<Text::Diff>. Then this is the output:
|
||||
|
||||
# +----+-----------------------+-----------------------+
|
||||
# | Elt|Got |Expected |
|
||||
# +----+-----------------------+-----------------------+
|
||||
# | 0|'Traditional Chinese' |'Traditional Chinese' |
|
||||
# * 1|'中国' |'中國' *
|
||||
# +----+-----------------------+-----------------------+
|
||||
|
||||
=head1 DEPLOYING
|
||||
|
||||
There are several basic ways of deploying Test::Differences requiring more or less
|
||||
labor by you or your users.
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
Fallback to C<is_deeply>.
|
||||
|
||||
This is your best option if you want this module to be optional.
|
||||
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
if (!eval q{ use Test::Differences; 1 }) {
|
||||
*eq_or_diff = \&is_deeply;
|
||||
}
|
||||
}
|
||||
|
||||
=item *
|
||||
|
||||
eval "use Test::Differences";
|
||||
|
||||
If you want to detect the presence of Test::Differences on the fly, something
|
||||
like the following code might do the trick for you:
|
||||
|
||||
use Test qw( !ok ); ## get all syms *except* ok
|
||||
|
||||
eval "use Test::Differences";
|
||||
use Data::Dumper;
|
||||
|
||||
sub ok {
|
||||
goto &eq_or_diff if defined &eq_or_diff && @_ > 1;
|
||||
@_ = map ref $_ ? Dumper( @_ ) : $_, @_;
|
||||
goto Test::&ok;
|
||||
}
|
||||
|
||||
plan tests => 1;
|
||||
|
||||
ok "a", "b";
|
||||
|
||||
=item *
|
||||
|
||||
PREREQ_PM => { .... "Test::Differences" => 0, ... }
|
||||
|
||||
This method will let CPAN and CPANPLUS users download it automatically. It
|
||||
will discomfit those users who choose/have to download all packages manually.
|
||||
|
||||
=item *
|
||||
|
||||
t/lib/Test/Differences.pm, t/lib/Text/Diff.pm, ...
|
||||
|
||||
By placing Test::Differences and its prerequisites in the t/lib directory, you
|
||||
avoid forcing your users to download the Test::Differences manually if they
|
||||
aren't using CPAN or CPANPLUS.
|
||||
|
||||
If you put a C<use lib "t/lib";> in the top of each test suite before the
|
||||
C<use Test::Differences;>, C<make test> should work well.
|
||||
|
||||
You might want to check once in a while for new Test::Differences releases
|
||||
if you do this.
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = "0.67"; # or "0.001_001" for a dev release
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
use Exporter;
|
||||
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw(
|
||||
eq_or_diff
|
||||
eq_or_diff_text
|
||||
eq_or_diff_data
|
||||
unified_diff
|
||||
context_diff
|
||||
oldstyle_diff
|
||||
table_diff
|
||||
);
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
use Text::Diff;
|
||||
use Data::Dumper;
|
||||
|
||||
{
|
||||
my $diff_style = 'Table';
|
||||
my %allowed_style = map { $_ => 1 } qw/Unified Context OldStyle Table/;
|
||||
sub _diff_style {
|
||||
return $diff_style unless @_;
|
||||
my $requested_style = shift;
|
||||
unless ( $allowed_style{$requested_style} ) {
|
||||
Carp::croak("Uknown style ($requested_style) requested for diff");
|
||||
}
|
||||
$diff_style = $requested_style;
|
||||
}
|
||||
}
|
||||
|
||||
sub unified_diff { _diff_style('Unified') }
|
||||
sub context_diff { _diff_style('Context') }
|
||||
sub oldstyle_diff { _diff_style('OldStyle') }
|
||||
sub table_diff { _diff_style('Table') }
|
||||
|
||||
sub _identify_callers_test_package_of_choice {
|
||||
## This is called at each test in case Test::Differences was used before
|
||||
## the base testing modules.
|
||||
## First see if %INC tells us much of interest.
|
||||
my $has_builder_pm = grep $_ eq "Test/Builder.pm", keys %INC;
|
||||
my $has_test_pm = grep $_ eq "Test.pm", keys %INC;
|
||||
|
||||
return "Test" if $has_test_pm && !$has_builder_pm;
|
||||
return "Test::Builder" if !$has_test_pm && $has_builder_pm;
|
||||
|
||||
if ( $has_test_pm && $has_builder_pm ) {
|
||||
## TODO: Look in caller's namespace for hints. For now, assume Builder.
|
||||
## This should only ever be an issue if multiple test suites end
|
||||
## up in memory at once.
|
||||
return "Test::Builder";
|
||||
}
|
||||
}
|
||||
|
||||
my $warned_of_unknown_test_lib;
|
||||
|
||||
sub eq_or_diff_text { $_[3] = { data_type => "text" }; goto &eq_or_diff; }
|
||||
sub eq_or_diff_data { $_[3] = { data_type => "data" }; goto &eq_or_diff; }
|
||||
|
||||
## This string is a cheat: it's used to see if the two arrays of values
|
||||
## are identical. The stringified values are joined using this joint
|
||||
## and compared using eq. This is a deep equality comparison for
|
||||
## references and a shallow one for scalars.
|
||||
my $joint = chr(0) . "A" . chr(1);
|
||||
|
||||
sub eq_or_diff {
|
||||
my ( @vals, $name, $options );
|
||||
$options = pop if @_ > 2 && ref $_[-1];
|
||||
( $vals[0], $vals[1], $name ) = @_;
|
||||
|
||||
my($data_type, $filename_a, $filename_b);
|
||||
if($options) {
|
||||
$data_type = $options->{data_type};
|
||||
$filename_a = $options->{filename_a};
|
||||
$filename_b = $options->{filename_b};
|
||||
}
|
||||
$data_type ||= "text" unless ref $vals[0] || ref $vals[1];
|
||||
$data_type ||= "data";
|
||||
|
||||
$filename_a ||= 'Got';
|
||||
$filename_b ||= 'Expected';
|
||||
|
||||
my @widths;
|
||||
|
||||
local $Data::Dumper::Deparse = 1
|
||||
unless($Test::Differences::NoDeparse);
|
||||
local $Data::Dumper::Indent = 1;
|
||||
local $Data::Dumper::Purity = 0;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
local $Data::Dumper::Deepcopy = 1;
|
||||
local $Data::Dumper::Quotekeys = 0;
|
||||
local $Data::Dumper::Useperl = 1;
|
||||
local $Data::Dumper::Sortkeys =
|
||||
exists $options->{Sortkeys} ? $options->{Sortkeys} : 1;
|
||||
my ( $got, $expected ) = map
|
||||
[ split /^/, Data::Dumper::Dumper($_) ],
|
||||
@vals;
|
||||
|
||||
my $caller = caller;
|
||||
|
||||
my $passed
|
||||
= join( $joint, @$got ) eq join( $joint, @$expected );
|
||||
|
||||
my $diff;
|
||||
unless ($passed) {
|
||||
my $context;
|
||||
|
||||
$context = $options->{context}
|
||||
if exists $options->{context};
|
||||
|
||||
$context = 2**31 unless defined $context;
|
||||
|
||||
confess "context must be an integer: '$context'\n"
|
||||
unless $context =~ /\A\d+\z/;
|
||||
|
||||
$diff = diff $got, $expected,
|
||||
{ CONTEXT => $context,
|
||||
STYLE => _diff_style(),
|
||||
FILENAME_A => $filename_a,
|
||||
FILENAME_B => $filename_b,
|
||||
OFFSET_A => $data_type eq "text" ? 1 : 0,
|
||||
OFFSET_B => $data_type eq "text" ? 1 : 0,
|
||||
INDEX_LABEL => $data_type eq "text" ? "Ln" : "Elt",
|
||||
};
|
||||
chomp $diff;
|
||||
$diff .= "\n";
|
||||
}
|
||||
|
||||
my $which = _identify_callers_test_package_of_choice;
|
||||
|
||||
if ( $which eq "Test" ) {
|
||||
@_
|
||||
= $passed
|
||||
? ( "", "", $name )
|
||||
: ( "\n$diff", "No differences", $name );
|
||||
goto &Test::ok;
|
||||
}
|
||||
elsif ( $which eq "Test::Builder" ) {
|
||||
my $test = Test::Builder->new;
|
||||
## TODO: Call exported_to here? May not need to because the caller
|
||||
## should have imported something based on Test::Builder already.
|
||||
$test->ok( $passed, $name );
|
||||
$test->diag($diff) unless $passed;
|
||||
}
|
||||
else {
|
||||
unless ($warned_of_unknown_test_lib) {
|
||||
Carp::cluck
|
||||
"Can't identify test lib in use, doesn't seem to be Test.pm or Test::Builder based\n";
|
||||
$warned_of_unknown_test_lib = 1;
|
||||
}
|
||||
## Play dumb and hope nobody notices the fool drooling in the corner
|
||||
if ($passed) {
|
||||
print "ok\n";
|
||||
}
|
||||
else {
|
||||
$diff =~ s/^/# /gm;
|
||||
print "not ok\n", $diff;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
=head2 C<Test> or C<Test::More>
|
||||
|
||||
This module "mixes in" with Test.pm or any of the test libraries based on
|
||||
Test::Builder (Test::Simple, Test::More, etc). It does this by peeking to see
|
||||
whether Test.pm or Test/Builder.pm is in %INC, so if you are not using one of
|
||||
those, it will print a warning and play dumb by not emitting test numbers (or
|
||||
incrementing them). If you are using one of these, it should interoperate
|
||||
nicely.
|
||||
|
||||
=head2 Exporting
|
||||
|
||||
Exports all 3 functions by default (and by design). Use
|
||||
|
||||
use Test::Differences ();
|
||||
|
||||
to suppress this behavior if you don't like the namespace pollution.
|
||||
|
||||
This module will not override functions like ok(), is(), is_deeply(), etc. If
|
||||
it did, then you could C<eval "use Test::Differences qw( is_deeply );"> to get
|
||||
automatic upgrading to diffing behaviors without the C<sub my_ok> shown above.
|
||||
Test::Differences intentionally does not provide this behavior because this
|
||||
would mean that Test::Differences would need to emulate every popular test
|
||||
module out there, which would require far more coding and maintenance that I'm
|
||||
willing to do. Use the eval and my_ok deployment shown above if you want some
|
||||
level of automation.
|
||||
|
||||
=head2 Unicode
|
||||
|
||||
Perls before 5.6.0 don't support characters > 255 at all, and 5.6.0
|
||||
seems broken. This means that you might get odd results using perl5.6.0
|
||||
with unicode strings.
|
||||
|
||||
=head2 C<Data::Dumper> and older Perls.
|
||||
|
||||
Relies on Data::Dumper (for now), which, prior to perl5.8, will not always
|
||||
report hashes in the same order. C< $Data::Dumper::Sortkeys > I<is> set to 1,
|
||||
so on more recent versions of Data::Dumper, this should not occur. Check CPAN
|
||||
to see if it's been peeled out of the main perl distribution and backported.
|
||||
Reported by Ilya Martynov <ilya@martynov.org>, although the Sortkeys "future
|
||||
perfect" workaround has been set in anticipation of a new Data::Dumper for a
|
||||
while. Note that the two hashes should report the same here:
|
||||
|
||||
not ok 5
|
||||
# Failed test (t/ctrl/05-home.t at line 51)
|
||||
# +----+------------------------+----+------------------------+
|
||||
# | Elt|Got | Elt|Expected |
|
||||
# +----+------------------------+----+------------------------+
|
||||
# | 0|{ | 0|{ |
|
||||
# | 1| 'password' => '', | 1| 'password' => '', |
|
||||
# * 2| 'method' => 'login', * | |
|
||||
# | 3| 'ctrl' => 'home', | 2| 'ctrl' => 'home', |
|
||||
# | | * 3| 'method' => 'login', *
|
||||
# | 4| 'email' => 'test' | 4| 'email' => 'test' |
|
||||
# | 5|} | 5|} |
|
||||
# +----+------------------------+----+------------------------+
|
||||
|
||||
Data::Dumper also overlooks the difference between
|
||||
|
||||
$a[0] = \$a[1];
|
||||
$a[1] = \$a[0]; # $a[0] = \$a[1]
|
||||
|
||||
and
|
||||
|
||||
$x = \$y;
|
||||
$y = \$x;
|
||||
@a = ( $x, $y ); # $a[0] = \$y, not \$a[1]
|
||||
|
||||
The former involves two scalars, the latter 4: $x, $y, and @a[0,1].
|
||||
This was carefully explained to me in words of two syllables or less by
|
||||
Yves Orton <demerphq@hotmail.com>. The plan to address this is to allow
|
||||
you to select Data::Denter or some other module of your choice as an
|
||||
option.
|
||||
|
||||
=head2 Code-refs
|
||||
|
||||
Test::Differences turns on C<$Data::Dumper::Deparse>, so any code-refs in your
|
||||
data structures will be turned into text before they are examined, using
|
||||
L<B::Deparse>. The precise text generated for a sub-ref might not be what you
|
||||
expect as it is generated from the compiled version of the code, but it should
|
||||
at least be consistent and spot differences correctly.
|
||||
|
||||
You can turn this behaviour off by setting C<$Test::Differences::NoDeparse>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Barrie Slaymaker <barries@slaysys.com> - original author
|
||||
|
||||
Curtis "Ovid" Poe <ovid@cpan.org>
|
||||
|
||||
David Cantrell <david@cantrell.org.uk>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright Barrie Slaymaker, Curtis "Ovid" Poe, and David Cantrell.
|
||||
|
||||
All Rights Reserved.
|
||||
|
||||
You may use, distribute and modify this software under the terms of the GNU
|
||||
public license, any version, or the Artistic license.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
515
database/perl/vendor/lib/Test/Exception.pm
vendored
Normal file
515
database/perl/vendor/lib/Test/Exception.pm
vendored
Normal file
@@ -0,0 +1,515 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::Exception;
|
||||
use Test::Builder;
|
||||
use Sub::Uplevel qw( uplevel );
|
||||
use base qw( Exporter );
|
||||
|
||||
our $VERSION = '0.43';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
|
||||
|
||||
my $Tester = Test::Builder->new;
|
||||
|
||||
sub import {
|
||||
my $self = shift;
|
||||
if ( @_ ) {
|
||||
my $package = caller;
|
||||
$Tester->exported_to( $package );
|
||||
$Tester->plan( @_ );
|
||||
};
|
||||
$self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Exception - Test exception-based code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::More tests => 5;
|
||||
use Test::Exception;
|
||||
|
||||
# or if you don't need Test::More
|
||||
|
||||
use Test::Exception tests => 5;
|
||||
|
||||
# then...
|
||||
|
||||
# Check that the stringified exception matches given regex
|
||||
throws_ok { $foo->method } qr/division by zero/, 'zero caught okay';
|
||||
|
||||
# Check an exception of the given class (or subclass) is thrown
|
||||
throws_ok { $foo->method } 'Error::Simple', 'simple error thrown';
|
||||
|
||||
# all Test::Exceptions subroutines are guaranteed to preserve the state
|
||||
# of $@ so you can do things like this after throws_ok and dies_ok
|
||||
like $@, 'what the stringified exception should look like';
|
||||
|
||||
# Check that something died - we do not care why
|
||||
dies_ok { $foo->method } 'expecting to die';
|
||||
|
||||
# Check that something did not die
|
||||
lives_ok { $foo->method } 'expecting to live';
|
||||
|
||||
# Check that a test runs without an exception
|
||||
lives_and { is $foo->method, 42 } 'method is 42';
|
||||
|
||||
# or if you don't like prototyped functions
|
||||
|
||||
throws_ok( sub { $foo->method }, qr/division by zero/,
|
||||
'zero caught okay' );
|
||||
throws_ok( sub { $foo->method }, 'Error::Simple',
|
||||
'simple error thrown' );
|
||||
dies_ok( sub { $foo->method }, 'expecting to die' );
|
||||
lives_ok( sub { $foo->method }, 'expecting to live' );
|
||||
lives_and( sub { is $foo->method, 42 }, 'method is 42' );
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a few convenience methods for testing exception based code. It is built with
|
||||
L<Test::Builder> and plays happily with L<Test::More> and friends.
|
||||
|
||||
If you are not already familiar with L<Test::More> now would be the time to go take a look.
|
||||
|
||||
You can specify the test plan when you C<use Test::Exception> in the same way as C<use Test::More>.
|
||||
See L<Test::More> for details.
|
||||
|
||||
NOTE: Test::Exception only checks for exceptions. It will ignore other methods of stopping
|
||||
program execution - including exit(). If you have an exit() in evalled code Test::Exception
|
||||
will not catch this with any of its testing functions.
|
||||
|
||||
NOTE: This module uses L<Sub::Uplevel> and relies on overriding
|
||||
C<CORE::GLOBAL::caller> to hide your test blocks from the call stack. If this
|
||||
use of global overrides concerns you, the L<Test::Fatal> module offers a more
|
||||
minimalist alternative.
|
||||
|
||||
=cut
|
||||
|
||||
sub _quiet_caller (;$) { ## no critic Prototypes
|
||||
my $height = $_[0];
|
||||
$height++;
|
||||
|
||||
if ( CORE::caller() eq 'DB' ) {
|
||||
# passthrough the @DB::args trick
|
||||
package DB;
|
||||
if( wantarray ) {
|
||||
if ( !@_ ) {
|
||||
return (CORE::caller($height))[0..2];
|
||||
}
|
||||
else {
|
||||
# If we got here, we are within a Test::Exception test, and
|
||||
# something is producing a stacktrace. In case this is a full
|
||||
# trace (i.e. confess() ), we have to make sure that the sub
|
||||
# args are not visible. If we do not do this, and the test in
|
||||
# question is throws_ok() with a regex, it will end up matching
|
||||
# against itself in the args to throws_ok().
|
||||
#
|
||||
# While it is possible (and maybe wise), to test if we are
|
||||
# indeed running under throws_ok (by crawling the stack right
|
||||
# up from here), the old behavior of Test::Exception was to
|
||||
# simply obliterate @DB::args altogether in _quiet_caller, so
|
||||
# we are just preserving the behavior to avoid surprises
|
||||
#
|
||||
my @frame_info = CORE::caller($height);
|
||||
@DB::args = ();
|
||||
return @frame_info;
|
||||
}
|
||||
}
|
||||
|
||||
# fallback if nothing above returns
|
||||
return CORE::caller($height);
|
||||
}
|
||||
else {
|
||||
if( wantarray and !@_ ) {
|
||||
return (CORE::caller($height))[0..2];
|
||||
}
|
||||
else {
|
||||
return CORE::caller($height);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _try_as_caller {
|
||||
my $coderef = shift;
|
||||
|
||||
# local works here because Sub::Uplevel has already overridden caller
|
||||
local *CORE::GLOBAL::caller;
|
||||
{ no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
|
||||
|
||||
eval { uplevel 3, $coderef };
|
||||
return $@;
|
||||
};
|
||||
|
||||
|
||||
sub _is_exception {
|
||||
my $exception = shift;
|
||||
return ref $exception || $exception ne '';
|
||||
};
|
||||
|
||||
|
||||
sub _exception_as_string {
|
||||
my ( $prefix, $exception ) = @_;
|
||||
return "$prefix normal exit" unless _is_exception( $exception );
|
||||
my $class = ref $exception;
|
||||
$exception = "$class ($exception)"
|
||||
if $class && "$exception" !~ m/^\Q$class/;
|
||||
chomp $exception;
|
||||
return "$prefix $exception";
|
||||
};
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<throws_ok>
|
||||
|
||||
Tests to see that a specific exception is thrown. throws_ok() has two forms:
|
||||
|
||||
throws_ok BLOCK REGEX, TEST_DESCRIPTION
|
||||
throws_ok BLOCK CLASS, TEST_DESCRIPTION
|
||||
|
||||
In the first form the test passes if the stringified exception matches the give regular expression. For example:
|
||||
|
||||
throws_ok { read_file( 'unreadable' ) } qr/No file/, 'no file';
|
||||
|
||||
If your perl does not support C<qr//> you can also pass a regex-like string, for example:
|
||||
|
||||
throws_ok { read_file( 'unreadable' ) } '/No file/', 'no file';
|
||||
|
||||
The second form of throws_ok() test passes if the exception is of the same class as the one supplied, or a subclass of that class. For example:
|
||||
|
||||
throws_ok { $foo->bar } "Error::Simple", 'simple error';
|
||||
|
||||
Will only pass if the C<bar> method throws an Error::Simple exception, or a subclass of an Error::Simple exception.
|
||||
|
||||
You can get the same effect by passing an instance of the exception you want to look for. The following is equivalent to the previous example:
|
||||
|
||||
my $SIMPLE = Error::Simple->new;
|
||||
throws_ok { $foo->bar } $SIMPLE, 'simple error';
|
||||
|
||||
Should a throws_ok() test fail it produces appropriate diagnostic messages. For example:
|
||||
|
||||
not ok 3 - simple error
|
||||
# Failed test (test.t at line 48)
|
||||
# expecting: Error::Simple exception
|
||||
# found: normal exit
|
||||
|
||||
Like all other Test::Exception functions you can avoid prototypes by passing a subroutine explicitly:
|
||||
|
||||
throws_ok( sub {$foo->bar}, "Error::Simple", 'simple error' );
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
||||
|
||||
A description of the exception being checked is used if no optional test description is passed.
|
||||
|
||||
NOTE: Remember when you C<die $string_without_a_trailing_newline> perl will
|
||||
automatically add the current script line number, input line number and a newline. This will
|
||||
form part of the string that throws_ok regular expressions match against.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub throws_ok (&$;$) {
|
||||
my ( $coderef, $expecting, $description ) = @_;
|
||||
unless (defined $expecting) {
|
||||
require Carp;
|
||||
Carp::croak( "throws_ok: must pass exception class/object or regex" );
|
||||
}
|
||||
$description = _exception_as_string( "threw", $expecting )
|
||||
unless defined $description;
|
||||
my $exception = _try_as_caller( $coderef );
|
||||
my $regex = $Tester->maybe_regex( $expecting );
|
||||
my $ok = $regex
|
||||
? ( $exception =~ m/$regex/ )
|
||||
: eval {
|
||||
$exception->isa( ref $expecting ? ref $expecting : $expecting )
|
||||
};
|
||||
$Tester->ok( $ok, $description );
|
||||
unless ( $ok ) {
|
||||
$Tester->diag( _exception_as_string( "expecting:", $expecting ) );
|
||||
$Tester->diag( _exception_as_string( "found:", $exception ) );
|
||||
};
|
||||
$@ = $exception;
|
||||
return $ok;
|
||||
};
|
||||
|
||||
|
||||
=item B<dies_ok>
|
||||
|
||||
Checks that a piece of code dies, rather than returning normally. For example:
|
||||
|
||||
sub div {
|
||||
my ( $a, $b ) = @_;
|
||||
return $a / $b;
|
||||
};
|
||||
|
||||
dies_ok { div( 1, 0 ) } 'divide by zero detected';
|
||||
|
||||
# or if you don't like prototypes
|
||||
dies_ok( sub { div( 1, 0 ) }, 'divide by zero detected' );
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
||||
|
||||
Remember: This test will pass if the code dies for any reason. If you care about the reason it might be more sensible to write a more specific test using throws_ok().
|
||||
|
||||
The test description is optional, but recommended.
|
||||
|
||||
=cut
|
||||
|
||||
sub dies_ok (&;$) {
|
||||
my ( $coderef, $description ) = @_;
|
||||
my $exception = _try_as_caller( $coderef );
|
||||
my $ok = $Tester->ok( _is_exception($exception), $description );
|
||||
$@ = $exception;
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
=item B<lives_ok>
|
||||
|
||||
Checks that a piece of code doesn't die. This allows your test script to continue, rather than aborting if you get an unexpected exception. For example:
|
||||
|
||||
sub read_file {
|
||||
my $file = shift;
|
||||
local $/;
|
||||
open my $fh, '<', $file or die "open failed ($!)\n";
|
||||
$file = <FILE>;
|
||||
return $file;
|
||||
};
|
||||
|
||||
my $file;
|
||||
lives_ok { $file = read_file('test.txt') } 'file read';
|
||||
|
||||
# or if you don't like prototypes
|
||||
lives_ok( sub { $file = read_file('test.txt') }, 'file read' );
|
||||
|
||||
Should a lives_ok() test fail it produces appropriate diagnostic messages. For example:
|
||||
|
||||
not ok 1 - file read
|
||||
# Failed test (test.t at line 15)
|
||||
# died: open failed (No such file or directory)
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
||||
|
||||
The test description is optional, but recommended.
|
||||
|
||||
=cut
|
||||
|
||||
sub lives_ok (&;$) {
|
||||
my ( $coderef, $description ) = @_;
|
||||
my $exception = _try_as_caller( $coderef );
|
||||
my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
|
||||
$Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
|
||||
$@ = $exception;
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
=item B<lives_and>
|
||||
|
||||
Run a test that may throw an exception. For example, instead of doing:
|
||||
|
||||
my $file;
|
||||
lives_ok { $file = read_file('answer.txt') } 'read_file worked';
|
||||
is $file, "42", 'answer was 42';
|
||||
|
||||
You can use lives_and() like this:
|
||||
|
||||
lives_and { is read_file('answer.txt'), "42" } 'answer is 42';
|
||||
# or if you don't like prototypes
|
||||
lives_and(sub {is read_file('answer.txt'), "42"}, 'answer is 42');
|
||||
|
||||
Which is the same as doing
|
||||
|
||||
is read_file('answer.txt'), "42\n", 'answer is 42';
|
||||
|
||||
unless C<read_file('answer.txt')> dies, in which case you get the same kind of error as lives_ok()
|
||||
|
||||
not ok 1 - answer is 42
|
||||
# Failed test (test.t at line 15)
|
||||
# died: open failed (No such file or directory)
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
||||
|
||||
The test description is optional, but recommended.
|
||||
|
||||
=cut
|
||||
|
||||
sub lives_and (&;$) {
|
||||
my ( $test, $description ) = @_;
|
||||
{
|
||||
my $ok = \&Test::Builder::ok;
|
||||
no warnings;
|
||||
local *Test::Builder::ok = sub {
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
$_[2] = $description unless defined $_[2];
|
||||
$ok->(@_);
|
||||
};
|
||||
use warnings;
|
||||
eval { $test->() } and return 1;
|
||||
};
|
||||
my $exception = $@;
|
||||
if ( _is_exception( $exception ) ) {
|
||||
$Tester->ok( 0, $description );
|
||||
$Tester->diag( _exception_as_string( "died:", $exception ) );
|
||||
};
|
||||
$@ = $exception;
|
||||
return;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 SKIPPING TEST::EXCEPTION TESTS
|
||||
|
||||
Sometimes we want to use Test::Exception tests in a test suite, but don't want to force the user to have Test::Exception installed. One way to do this is to skip the tests if Test::Exception is absent. You can do this with code something like this:
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Test::More;
|
||||
|
||||
BEGIN {
|
||||
eval "use Test::Exception";
|
||||
plan skip_all => "Test::Exception needed" if $@;
|
||||
}
|
||||
|
||||
plan tests => 2;
|
||||
# ... tests that need Test::Exception ...
|
||||
|
||||
Note that we load Test::Exception in a C<BEGIN> block ensuring that the subroutine prototypes are in place before the rest of the test script is compiled.
|
||||
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
There are some edge cases in Perl's exception handling where Test::Exception will miss exceptions
|
||||
thrown in DESTROY blocks. See the RT bug L<http://rt.cpan.org/Ticket/Display.html?id=24678> for
|
||||
details, along with the t/edge-cases.t in the distribution test suite. These will be addressed in
|
||||
a future Test::Exception release.
|
||||
|
||||
If you find any more bugs please let me know by e-mail, or report the problem with
|
||||
L<http://rt.cpan.org/>.
|
||||
|
||||
|
||||
=head1 COMMUNITY
|
||||
|
||||
=over 4
|
||||
|
||||
=item perl-qa
|
||||
|
||||
If you are interested in testing using Perl I recommend you visit L<http://qa.perl.org/> and join the excellent perl-qa mailing list. See L<http://lists.perl.org/showlist.cgi?name=perl-qa> for details on how to subscribe.
|
||||
|
||||
=item perlmonks
|
||||
|
||||
You can find users of Test::Exception, including the module author, on L<http://www.perlmonks.org/>. Feel free to ask questions on Test::Exception there.
|
||||
|
||||
=item CPAN::Forum
|
||||
|
||||
The CPAN Forum is a web forum for discussing Perl's CPAN modules. The Test::Exception forum can be found at L<http://www.cpanforum.com/dist/Test-Exception>.
|
||||
|
||||
=item AnnoCPAN
|
||||
|
||||
AnnoCPAN is a web site that allows community annotations of Perl module documentation. The Test::Exception annotations can be found at L<http://annocpan.org/~ADIE/Test-Exception/>.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
If you think this module should do something that it doesn't (or does something that it shouldn't) please let me know.
|
||||
|
||||
You can see my current to do list at L<http://adrianh.tadalist.com/lists/public/15421>, with an RSS feed of changes at L<http://adrianh.tadalist.com/lists/feed_public/15421>.
|
||||
|
||||
|
||||
=head1 ACKNOWLEDGMENTS
|
||||
|
||||
Thanks to chromatic and Michael G Schwern for the excellent Test::Builder, without which this module wouldn't be possible.
|
||||
|
||||
Thanks to
|
||||
Adam Kennedy,
|
||||
Andy Lester,
|
||||
Aristotle Pagaltzis,
|
||||
Ben Prew,
|
||||
Cees Hek,
|
||||
Chris Dolan,
|
||||
chromatic,
|
||||
Curt Sampson,
|
||||
David Cantrell,
|
||||
David Golden,
|
||||
David Tulloh,
|
||||
David Wheeler,
|
||||
J. K. O'Brien,
|
||||
Janek Schleicher,
|
||||
Jim Keenan,
|
||||
Jos I. Boumans,
|
||||
Joshua ben Jore,
|
||||
Jost Krieger,
|
||||
Mark Fowler,
|
||||
Michael G Schwern,
|
||||
Nadim Khemir,
|
||||
Paul McCann,
|
||||
Perrin Harkins,
|
||||
Peter Rabbitson,
|
||||
Peter Scott,
|
||||
Ricardo Signes,
|
||||
Rob Muhlestein,
|
||||
Scott R. Godin,
|
||||
Steve Purkis,
|
||||
Steve,
|
||||
Tim Bunce,
|
||||
and various anonymous folk for comments, suggestions, bug reports and patches.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adrian Howard <adrianh@quietstars.com>
|
||||
|
||||
If you can spare the time, please drop me a line if you find this module useful.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<http://del.icio.us/tag/Test::Exception>
|
||||
|
||||
Delicious links on Test::Exception.
|
||||
|
||||
=item L<Test::Fatal>
|
||||
|
||||
A slightly different interface to testing exceptions, without overriding C<CORE::caller>.
|
||||
|
||||
=item L<Test::Warnings> & L<Test::Warn> & L<Test::NoWarnings>
|
||||
|
||||
Modules to help test warnings.
|
||||
|
||||
=item L<Test::Builder>
|
||||
|
||||
Support module for building test libraries.
|
||||
|
||||
=item L<Test::Simple> & L<Test::More>
|
||||
|
||||
Basic utilities for writing tests.
|
||||
|
||||
=item L<http://qa.perl.org/test-modules.html>
|
||||
|
||||
Overview of some of the many testing modules available on CPAN.
|
||||
|
||||
=item L<http://del.icio.us/tag/perl+testing>
|
||||
|
||||
Delicious links on perl testing.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 LICENCE
|
||||
|
||||
Copyright 2002-2007 Adrian Howard, All Rights Reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
463
database/perl/vendor/lib/Test/Fatal.pm
vendored
Normal file
463
database/perl/vendor/lib/Test/Fatal.pm
vendored
Normal file
@@ -0,0 +1,463 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
package Test::Fatal;
|
||||
# ABSTRACT: incredibly simple helpers for testing code with exceptions
|
||||
$Test::Fatal::VERSION = '0.016';
|
||||
#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 B<Achtung!> C<exception> intentionally does not manipulate the call stack.
|
||||
#pod User-written test functions that use C<exception> must be careful to avoid
|
||||
#pod false positives if exceptions use stack traces that show arguments. For a more
|
||||
#pod magical approach involving globally overriding C<caller>, see
|
||||
#pod L<Test::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 If you really want a test function that passes the test name, wrap the
|
||||
#pod arguments in an array reference to hide the literal text from a stack trace:
|
||||
#pod
|
||||
#pod sub exception_like(&$) {
|
||||
#pod my ($code, $args) = @_;
|
||||
#pod my ($pattern, $name) = @$args;
|
||||
#pod like( &exception($code), $pattern, $name );
|
||||
#pod }
|
||||
#pod
|
||||
#pod exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );
|
||||
#pod
|
||||
#pod To aid in avoiding the problem where the pattern is seen in the exception
|
||||
#pod because of the call stack, C<$Carp::MAxArgNums> is locally set to -1 when the
|
||||
#pod code block is called. If you really don't want that, set it back to whatever
|
||||
#pod value you like at the beginning of the code block. Obviously, this solution
|
||||
#pod doens't affect all possible ways that args of subroutines in the call stack
|
||||
#pod might taint the test. The intention here is to prevent some false passes from
|
||||
#pod people who didn't read the documentation. Your punishment for reading it is
|
||||
#pod that you must consider whether to do anything about this.
|
||||
#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 = defined $Test::Builder::Level
|
||||
? $Test::Builder::Level - $REAL_CALCULATED_TBL
|
||||
: 0;
|
||||
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;
|
||||
local $Carp::MaxArgNums = -1;
|
||||
$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 $tap_pos = $Tester->current_test;
|
||||
|
||||
my $exception = exception( \&$code );
|
||||
|
||||
$name ||= $tap_pos != $Tester->current_test
|
||||
? "...and code should throw an exception"
|
||||
: "code should throw an exception";
|
||||
|
||||
my $ok = $Tester->ok( $exception, $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 $tap_pos = $Tester->current_test;
|
||||
|
||||
my $exception = exception( \&$code );
|
||||
|
||||
$name ||= $tap_pos != $Tester->current_test
|
||||
? "...and code should not throw an exception"
|
||||
: "code should not throw an exception";
|
||||
|
||||
my $ok = $Tester->ok( ! $exception, $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.016
|
||||
|
||||
=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>.
|
||||
|
||||
B<Achtung!> C<exception> intentionally does not manipulate the call stack.
|
||||
User-written test functions that use C<exception> must be careful to avoid
|
||||
false positives if exceptions use stack traces that show arguments. For a more
|
||||
magical approach involving globally overriding C<caller>, see
|
||||
L<Test::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' );
|
||||
|
||||
If you really want a test function that passes the test name, wrap the
|
||||
arguments in an array reference to hide the literal text from a stack trace:
|
||||
|
||||
sub exception_like(&$) {
|
||||
my ($code, $args) = @_;
|
||||
my ($pattern, $name) = @$args;
|
||||
like( &exception($code), $pattern, $name );
|
||||
}
|
||||
|
||||
exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );
|
||||
|
||||
To aid in avoiding the problem where the pattern is seen in the exception
|
||||
because of the call stack, C<$Carp::MAxArgNums> is locally set to -1 when the
|
||||
code block is called. If you really don't want that, set it back to whatever
|
||||
value you like at the beginning of the code block. Obviously, this solution
|
||||
doens't affect all possible ways that args of subroutines in the call stack
|
||||
might taint the test. The intention here is to prevent some false passes from
|
||||
people who didn't read the documentation. Your punishment for reading it is
|
||||
that you must consider whether to do anything about this.
|
||||
|
||||
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 CONTRIBUTORS
|
||||
|
||||
=for stopwords David Golden Graham Knop Jesse Luehrs Joel Bernstein Karen Etheridge
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Graham Knop <haarg@haarg.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@tozt.net>
|
||||
|
||||
=item *
|
||||
|
||||
Joel Bernstein <joel@fysh.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=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
|
||||
1747
database/perl/vendor/lib/Test/File.pm
vendored
Normal file
1747
database/perl/vendor/lib/Test/File.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
448
database/perl/vendor/lib/Test/File/ShareDir.pm
vendored
Normal file
448
database/perl/vendor/lib/Test/File/ShareDir.pm
vendored
Normal file
@@ -0,0 +1,448 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Create a Fake ShareDir for your modules for testing.
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
use File::ShareDir 1.00 qw();
|
||||
use Exporter qw();
|
||||
use Test::File::ShareDir::Utils qw( extract_dashes );
|
||||
use Carp qw( croak );
|
||||
use parent qw( Exporter );
|
||||
|
||||
our @EXPORT_OK = qw( with_dist_dir with_module_dir );
|
||||
|
||||
sub import {
|
||||
my ( $package, @args ) = @_;
|
||||
|
||||
my ( @imports, %params );
|
||||
|
||||
# ->import( { }, qw( imports ) )
|
||||
if ( 'HASH' eq ref $args[0] ) {
|
||||
%params = %{ shift @args };
|
||||
@imports = @args;
|
||||
}
|
||||
else {
|
||||
# ->import( -arg => value, -arg => value, @imports );
|
||||
while (@args) {
|
||||
if ( $args[0] =~ /\A-(.*)\z/msx ) {
|
||||
$params{ $args[0] } = $args[1];
|
||||
splice @args, 0, 2, ();
|
||||
next;
|
||||
}
|
||||
push @imports, shift @args;
|
||||
}
|
||||
}
|
||||
|
||||
if ( keys %params ) {
|
||||
require Test::File::ShareDir::TempDirObject;
|
||||
|
||||
my $tempdir_object = Test::File::ShareDir::TempDirObject->new( \%params );
|
||||
|
||||
for my $module ( $tempdir_object->_module_names ) {
|
||||
$tempdir_object->_install_module($module);
|
||||
}
|
||||
|
||||
for my $dist ( $tempdir_object->_dist_names ) {
|
||||
$tempdir_object->_install_dist($dist);
|
||||
}
|
||||
|
||||
unshift @INC, $tempdir_object->_tempdir->stringify;
|
||||
|
||||
}
|
||||
if (@imports) {
|
||||
$package->export_to_level( 1, undef, @imports );
|
||||
}
|
||||
return;
|
||||
|
||||
}
|
||||
|
||||
# This code is just to make sure any guard objects
|
||||
# are not lexically visible to the sub they contain creating a self reference.
|
||||
sub _mk_clearer {
|
||||
my ($clearee) = @_;
|
||||
return sub { $clearee->clear };
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub with_dist_dir {
|
||||
my ( $config, $code ) = @_;
|
||||
if ( 'CODE' ne ( ref $code || q{} ) ) {
|
||||
croak( 'CodeRef expected at end of with_dist_dir(), ' . ( ref $code || qq{scalar="$code"} ) . ' found' );
|
||||
}
|
||||
require Test::File::ShareDir::Object::Dist;
|
||||
require Scope::Guard;
|
||||
my $dist_object = Test::File::ShareDir::Object::Dist->new( extract_dashes( 'dists', $config ) );
|
||||
$dist_object->install_all_dists();
|
||||
$dist_object->register();
|
||||
my $guard = Scope::Guard->new( _mk_clearer($dist_object) ); ## no critic (Variables::ProhibitUnusedVarsStricter)
|
||||
return $code->();
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub with_module_dir {
|
||||
my ( $config, $code ) = @_;
|
||||
if ( 'CODE' ne ( ref $code || q{} ) ) {
|
||||
croak( 'CodeRef expected at end of with_module_dir(), ' . ( ref $code || qq{scalar="$code"} ) . ' found' );
|
||||
}
|
||||
|
||||
require Test::File::ShareDir::Object::Module;
|
||||
require Scope::Guard;
|
||||
|
||||
my $module_object = Test::File::ShareDir::Object::Module->new( extract_dashes( 'modules', $config ) );
|
||||
|
||||
$module_object->install_all_modules();
|
||||
$module_object->register();
|
||||
my $guard = Scope::Guard->new( _mk_clearer($module_object) ); ## no critic (Variables::ProhibitUnusedVarsStricter)
|
||||
|
||||
return $code->();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir - Create a Fake ShareDir for your modules for testing.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::More;
|
||||
|
||||
# use FindBin; optional
|
||||
|
||||
use Test::File::ShareDir
|
||||
# -root => "$FindBin::Bin/../" # optional,
|
||||
-share => {
|
||||
-module => { 'My::Module' => 'share/MyModule' }
|
||||
-dist => { 'My-Dist' => 'share/somefolder' }
|
||||
};
|
||||
|
||||
use My::Module;
|
||||
|
||||
use File::ShareDir qw( module_dir dist_dir );
|
||||
|
||||
module_dir( 'My::Module' ) # dir with files from $dist/share/MyModule
|
||||
|
||||
dist_dir( 'My-Dist' ) # dir with files from $dist/share/somefolder
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Test::File::ShareDir> is some low level plumbing to enable a distribution to perform tests while consuming its own C<share>
|
||||
directories in a manner similar to how they will be once installed.
|
||||
|
||||
This allows C<File::ShareDir> to see the I<latest> version of content instead of simply whatever is installed on whichever target
|
||||
system you happen to be testing on.
|
||||
|
||||
B<Note:> This module only has support for creating 'new' style share dirs and are NOT compatible with old File::ShareDirs.
|
||||
|
||||
For this reason, unless you have File::ShareDir 1.00 or later installed, this module will not be usable by you.
|
||||
|
||||
=head1 SIMPLE INTERFACE
|
||||
|
||||
Starting with version C<0.4.0>, there are a few extra interfaces you can use.
|
||||
|
||||
These will probably be more useful, and easier to grok, because they don't have a layer of
|
||||
indirection in order to simultaneously support both C<Module> and C<Dist> C<ShareDir>'s.
|
||||
|
||||
=head2 Simple Exporter Interfaces
|
||||
|
||||
=head3 C<Test::File::ShareDir::Dist>
|
||||
|
||||
L<< C<Test::File::ShareDir::Dist>|Test::File::ShareDir::Dist >> provides a simple export interface
|
||||
for making C<TempDir> C<ShareDir>'s from a given path:
|
||||
|
||||
use Test::File::ShareDir::Dist { "Dist-Name" => "share/" };
|
||||
|
||||
This will automatically create a C<ShareDir> for C<Dist-Name> in a C<TempDir> based on the contents of C<CWD/share/>
|
||||
|
||||
See L<< C<Test::File::ShareDir::Dist>|Test::File::ShareDir::Dist >> for details.
|
||||
|
||||
=head3 C<Test::File::ShareDir::Module>
|
||||
|
||||
L<< C<Test::File::ShareDir::Module>|Test::File::ShareDir::Module >> provides a simple export interface
|
||||
for making C<TempDir> C<ShareDir>'s from a given path:
|
||||
|
||||
use Test::File::ShareDir::Module { "Module::Name" => "share/" };
|
||||
|
||||
This will automatically create a C<ShareDir> for C<Module::Name> in a C<TempDir> based on the contents of C<CWD/share/>
|
||||
|
||||
See L<< C<Test::File::ShareDir::Module>|Test::File::ShareDir::Module >> for details.
|
||||
|
||||
=head2 Simple Object Oriented Interfaces
|
||||
|
||||
=head3 C<Test::File::ShareDir::Object::Dist>
|
||||
|
||||
L<< C<Test::File::ShareDir::Object::Dist>|Test::File::ShareDir::Object::Dist >> provides a simple object oriented interface for
|
||||
making C<TempDir> C<ShareDir>'s from a given path:
|
||||
|
||||
use Test::File::ShareDir::Object::Dist;
|
||||
|
||||
my $obj = Test::File::ShareDir::Object::Dist->new( dists => { "Dist-Name" => "share/" } );
|
||||
$obj->install_all_dists;
|
||||
$obj->register;
|
||||
|
||||
This will automatically create a C<ShareDir> for C<Dist-Name> in a C<TempDir> based on the contents of C<CWD/share/>
|
||||
|
||||
See L<< C<Test::File::ShareDir::Object::Dist>|Test::File::ShareDir::Object::Dist >> for details.
|
||||
|
||||
=head3 C<Test::File::ShareDir::Object::Module>
|
||||
|
||||
L<< C<Test::File::ShareDir::Object::Module>|Test::File::ShareDir::Object::Module >> provides a simple object oriented interface
|
||||
for making C<TempDir> C<ShareDir>'s from a given path:
|
||||
|
||||
use Test::File::ShareDir::Object::Module;
|
||||
|
||||
my $obj = Test::File::ShareDir::Object::Module->new( modules => { "Module::Name" => "share/" } );
|
||||
$obj->install_all_modules;
|
||||
$obj->register;
|
||||
|
||||
This will automatically create a C<ShareDir> for C<Module::Name> in a C<TempDir> based on the contents of C<CWD/share/>
|
||||
|
||||
See L<< C<Test::File::ShareDir::Object::Module>|Test::File::ShareDir::Object::Module >> for details.
|
||||
|
||||
=head1 SCOPE LIMITED UTILITIES
|
||||
|
||||
C<Test::File::ShareDir> provides a few utility functions to aide in temporarily adjusting C<ShareDir> behavior.
|
||||
|
||||
use Test::File::ShareDir qw( with_dist_dir with_module_dir );
|
||||
|
||||
with_dist_dir({ 'Dist-Name' => 'Some/Path' }, sub {
|
||||
# dist_dir() now behaves differently here
|
||||
});
|
||||
with_module_dir({ 'Module::Name' => 'Some/Path' }, sub {
|
||||
# module_dir() now behaves differently here
|
||||
});
|
||||
|
||||
See L<< C<EXPORTABLE FUNCTIONS>|/EXPORTABLE FUNCTIONS >> for details.
|
||||
|
||||
=head1 IMPORTING
|
||||
|
||||
Since C<1.001000>, there are 2 ways of passing arguments to C<import>
|
||||
|
||||
use Foo { -root => ... options }, qw( functions to import );
|
||||
use Foo -optname => option, -optname => option, qw( functions to import );
|
||||
|
||||
Both should work, but the former might be less prone to accidental issues.
|
||||
|
||||
=head2 IMPORT OPTIONS
|
||||
|
||||
=head3 -root
|
||||
|
||||
This parameter is the prefix the other paths are relative to.
|
||||
|
||||
If this parameter is not specified, it defaults to the Current Working Directory ( C<CWD> ).
|
||||
|
||||
In versions prior to C<0.3.0>, this value was mandatory.
|
||||
|
||||
The rationale behind using C<CWD> as the default value is as follows.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Most users of this module are likely to be using it to test distributions
|
||||
|
||||
=item * Most users of this module will be using it in C<$project/t/> to load files from C<$project/share/>
|
||||
|
||||
=item * Most C<CPAN> tools run tests with C<CWD> = $project
|
||||
|
||||
=back
|
||||
|
||||
Therefor, defaulting to C<CWD> is a reasonably sane default for most people, but where it is not it can
|
||||
still be overridden.
|
||||
|
||||
-root => "$FindBin::Bin/../" # resolves to project root from t/ regardless of Cwd.
|
||||
|
||||
=head3 -share
|
||||
|
||||
This parameter is mandatory, and contains a C<hashref> containing the data that explains what directories you want shared.
|
||||
|
||||
-share => { ..... }
|
||||
|
||||
=head4 -module
|
||||
|
||||
C<-module> contains a C<hashref> mapping Module names to path names for module_dir style share dirs.
|
||||
|
||||
-share => {
|
||||
-module => { 'My::Module' => 'share/mymodule/', }
|
||||
}
|
||||
|
||||
...
|
||||
|
||||
module_dir('My::Module')
|
||||
|
||||
Notedly, it is a C<hashref>, which means there is a limitation of one share dir per module. This is simply because having more
|
||||
than one share dir per module makes no sense at all.
|
||||
|
||||
=head4 -dist
|
||||
|
||||
C<-dist> contains a C<hashref> mapping Distribution names to path names for dist_dir style share dirs. The same limitation
|
||||
applied to C<-module> applies here.
|
||||
|
||||
-share => {
|
||||
-dist => { 'My-Dist' => 'share/mydist' }
|
||||
}
|
||||
...
|
||||
dist_dir('My-Dist')
|
||||
|
||||
=head1 EXPORTABLE FUNCTIONS
|
||||
|
||||
=head2 with_dist_dir
|
||||
|
||||
Sets up a C<ShareDir> environment with limited context.
|
||||
|
||||
# with_dist_dir(\%config, \&sub);
|
||||
with_dist_dir( { 'Dist-Name' => 'share/' } => sub {
|
||||
|
||||
# File::ShareDir resolves to a copy of share/ in this context.
|
||||
|
||||
} );
|
||||
|
||||
C<%config> can contain anything L<< C<Test::File::ShareDir::Dist>|Test::File::ShareDir::Dist >> accepts.
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<-root>: Defaults to C<$CWD>
|
||||
|
||||
=item C<I<$distName>>: Declare C<$distName>'s C<ShareDir>.
|
||||
|
||||
=back
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head2 with_module_dir
|
||||
|
||||
Sets up a C<ShareDir> environment with limited context.
|
||||
|
||||
# with_module_dir(\%config, \&sub);
|
||||
with_module_dir( { 'Module::Name' => 'share/' } => sub {
|
||||
|
||||
# File::ShareDir resolves to a copy of share/ in this context.
|
||||
|
||||
} );
|
||||
|
||||
C<%config> can contain anything L<< C<Test::File::ShareDir::Module>|Test::File::ShareDir::Module >> accepts.
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<-root>: Defaults to C<$CWD>
|
||||
|
||||
=item C<I<$moduleName>>: Declare C<$moduleName>'s C<ShareDir>.
|
||||
|
||||
=back
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir",
|
||||
"interface":"exporter"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 THANKS
|
||||
|
||||
Thanks to the C<#distzilla> crew for ideas,suggestions, code review and debugging, even though not all of it made it into releases.
|
||||
|
||||
=for stopwords DOLMEN ETHER HAARG RJBS
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<DOLMEN|cpan:///author/dolmen>
|
||||
|
||||
=item * L<ETHER|cpan:///author/ether>
|
||||
|
||||
=item * L<HAARG|cpan:///author/haarg>
|
||||
|
||||
=item * L<RJBS|cpan:///author/rjbs>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
94
database/perl/vendor/lib/Test/File/ShareDir/Dist.pm
vendored
Normal file
94
database/perl/vendor/lib/Test/File/ShareDir/Dist.pm
vendored
Normal file
@@ -0,0 +1,94 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::Dist;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Simplified dist oriented ShareDir tester
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
use File::ShareDir 1.00 qw();
|
||||
use Test::File::ShareDir::Utils qw( extract_dashes );
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub import {
|
||||
my ( undef, $arg ) = @_;
|
||||
|
||||
if ( not ref $arg or 'HASH' ne ref $arg ) {
|
||||
require Carp;
|
||||
return Carp::croak q[Must pass a hashref];
|
||||
}
|
||||
|
||||
my %input_config = %{$arg};
|
||||
|
||||
require Test::File::ShareDir::Object::Dist;
|
||||
|
||||
my $dist_object = Test::File::ShareDir::Object::Dist->new(extract_dashes('dists', \%input_config ));
|
||||
$dist_object->install_all_dists();
|
||||
$dist_object->register();
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::Dist - Simplified dist oriented ShareDir tester
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::File::ShareDir::Dist {
|
||||
'-root' => 'some/root/path',
|
||||
'Dist-Zilla-Plugin-Foo' => 'share/DZPF',
|
||||
};
|
||||
|
||||
C<-root> is optional, and defaults to C<cwd>
|
||||
|
||||
B<NOTE:> There's a bug prior to 5.18 with C<< use Foo { -key => } >>, so for backwards compatibility, make sure you either quote
|
||||
the key: C<< use Foo { '-key' => } >>, or make it the non-first key.
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir::Dist",
|
||||
"interface":"exporter"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
94
database/perl/vendor/lib/Test/File/ShareDir/Module.pm
vendored
Normal file
94
database/perl/vendor/lib/Test/File/ShareDir/Module.pm
vendored
Normal file
@@ -0,0 +1,94 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::Module;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Simplified module oriented ShareDir tester
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
use File::ShareDir 1.00 qw();
|
||||
use Test::File::ShareDir::Utils qw( extract_dashes );
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub import {
|
||||
my ( undef, $arg ) = @_;
|
||||
|
||||
if ( not ref $arg or 'HASH' ne ref $arg ) {
|
||||
require Carp;
|
||||
return Carp::croak q[Must pass a hashref];
|
||||
}
|
||||
|
||||
my %input_config = %{$arg};
|
||||
|
||||
require Test::File::ShareDir::Object::Module;
|
||||
|
||||
my $module_object = Test::File::ShareDir::Object::Module->new(extract_dashes('modules', \%input_config ));
|
||||
$module_object->install_all_modules();
|
||||
$module_object->register();
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::Module - Simplified module oriented ShareDir tester
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::File::ShareDir::Module {
|
||||
'-root' => "some/root/path",
|
||||
'Module::Foo' => "share/ModuleFoo",
|
||||
};
|
||||
|
||||
C<-root> is optional, and defaults to C<cwd>
|
||||
|
||||
B<NOTE:> There's a bug prior to 5.18 with C<< use Foo { -key => } >>, so for backwards compatibility, make sure you either quote
|
||||
the key: C<< use Foo { '-key' => } >>, or make it the non-first key.
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir::Module",
|
||||
"interface":"exporter"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
298
database/perl/vendor/lib/Test/File/ShareDir/Object/Dist.pm
vendored
Normal file
298
database/perl/vendor/lib/Test/File/ShareDir/Object/Dist.pm
vendored
Normal file
@@ -0,0 +1,298 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::Object::Dist;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Object Oriented ShareDir creation for distributions
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
use Class::Tiny {
|
||||
inc => sub {
|
||||
require Test::File::ShareDir::Object::Inc;
|
||||
return Test::File::ShareDir::Object::Inc->new();
|
||||
},
|
||||
dists => sub {
|
||||
return {};
|
||||
},
|
||||
root => sub {
|
||||
require Path::Tiny;
|
||||
return Path::Tiny::path(q[./])->absolute;
|
||||
},
|
||||
};
|
||||
|
||||
use Carp qw( carp );
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub __rcopy { require File::Copy::Recursive; goto \&File::Copy::Recursive::rcopy; }
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub dist_names {
|
||||
my ($self) = @_;
|
||||
return keys %{ $self->dists };
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub dist_share_target_dir {
|
||||
my ( $self, $distname ) = @_;
|
||||
return $self->inc->dist_tempdir->child($distname);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub dist_share_source_dir {
|
||||
my ( $self, $distname ) = @_;
|
||||
require Path::Tiny;
|
||||
return Path::Tiny::path( $self->dists->{$distname} )->absolute( $self->root );
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub install_dist {
|
||||
my ( $self, $distname ) = @_;
|
||||
my $source = $self->dist_share_source_dir($distname);
|
||||
my $target = $self->dist_share_target_dir($distname);
|
||||
return __rcopy( $source, $target );
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub install_all_dists {
|
||||
my ($self) = @_;
|
||||
for my $dist ( $self->dist_names ) {
|
||||
$self->install_dist($dist);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub add_to_inc {
|
||||
my ($self) = @_;
|
||||
carp 'add_to_inc deprecated since 1.001000, use register';
|
||||
return $self->register;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub register {
|
||||
my ($self) = @_;
|
||||
$self->inc->register;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub clear {
|
||||
my ($self) = @_;
|
||||
$self->inc->clear;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::Object::Dist - Object Oriented ShareDir creation for distributions
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::File::ShareDir::Object::Dist;
|
||||
|
||||
my $dir = Test::File::ShareDir::Object::Dist->new(
|
||||
root => "some/path",
|
||||
dists => {
|
||||
"Hello-Nurse" => "share/HN"
|
||||
},
|
||||
);
|
||||
|
||||
$dir->install_all_dists;
|
||||
$dir->add_to_inc;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<dist_names>
|
||||
|
||||
my @names = $instance->dist_names();
|
||||
|
||||
Returns the names of all distributions listed in the C<dists> set.
|
||||
|
||||
=head2 C<dist_share_target_dir>
|
||||
|
||||
my $dir = $instance->dist_share_target_dir("Dist-Name");
|
||||
|
||||
Returns the path where the C<ShareDir> will be created for C<Dist-Name>
|
||||
|
||||
=head2 C<dist_share_source_dir>
|
||||
|
||||
my $dir = $instance->dist_share_source_dir("Dist-Name");
|
||||
|
||||
Returns the path where the C<ShareDir> will be B<COPIED> I<FROM> for C<Dist-Name>
|
||||
|
||||
=head2 C<install_dist>
|
||||
|
||||
$instance->install_dist("Dist-Name");
|
||||
|
||||
Installs C<Dist-Name>'s C<ShareDir>
|
||||
|
||||
=head2 C<install_all_dists>
|
||||
|
||||
$instance->install_all_dists();
|
||||
|
||||
Installs all C<dist_names>
|
||||
|
||||
=head2 C<add_to_inc>
|
||||
|
||||
B<DEPRECATED:> Use C<register> instead.
|
||||
|
||||
=head2 C<register>
|
||||
|
||||
$instance->register();
|
||||
|
||||
Adds the C<Tempdir> C<ShareDir> ( C<inc> ) to the global C<@INC>
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head2 C<clear>
|
||||
|
||||
$instance->clear();
|
||||
|
||||
Removes the C<Tempdir> C<ShareDir> ( C<inc> ) from the global C<@INC>
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<inc>
|
||||
|
||||
A C<Test::File::ShareDir::Object::Inc> object.
|
||||
|
||||
=head2 C<dists>
|
||||
|
||||
A hash of :
|
||||
|
||||
Dist-Name => "relative/path"
|
||||
|
||||
=head2 C<root>
|
||||
|
||||
The origin all paths's are relative to.
|
||||
|
||||
( Defaults to C<cwd> )
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir::Object::Dist",
|
||||
"interface":"class",
|
||||
"inherits":"Class::Tiny::Object"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
209
database/perl/vendor/lib/Test/File/ShareDir/Object/Inc.pm
vendored
Normal file
209
database/perl/vendor/lib/Test/File/ShareDir/Object/Inc.pm
vendored
Normal file
@@ -0,0 +1,209 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::Object::Inc;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Shared tempdir object code to inject into @INC
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
my @cache;
|
||||
|
||||
use Class::Tiny {
|
||||
tempdir => sub {
|
||||
require Path::Tiny;
|
||||
my $dir = Path::Tiny::tempdir( CLEANUP => 1 );
|
||||
push @cache, $dir; # explicit keepalive
|
||||
return $dir;
|
||||
},
|
||||
module_tempdir => sub {
|
||||
my ($self) = @_;
|
||||
my $dir = $self->tempdir->child('auto/share/module');
|
||||
$dir->mkpath();
|
||||
return $dir->absolute;
|
||||
},
|
||||
dist_tempdir => sub {
|
||||
my ($self) = @_;
|
||||
my $dir = $self->tempdir->child('auto/share/dist');
|
||||
$dir->mkpath();
|
||||
return $dir->absolute;
|
||||
},
|
||||
};
|
||||
use Carp qw( carp );
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub add_to_inc {
|
||||
my ($self) = @_;
|
||||
carp 'add_to_inc deprecated sice 1.001000, use register instead';
|
||||
return $self->register;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub register {
|
||||
my ($self) = @_;
|
||||
unshift @INC, $self->tempdir->stringify;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub clear {
|
||||
my ($self) = @_;
|
||||
## no critic (Variables::RequireLocalizedPunctuationVars)
|
||||
@INC = grep { ref or $_ ne $self->tempdir->stringify } @INC;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::Object::Inc - Shared tempdir object code to inject into @INC
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::File::ShareDir::Object::Inc;
|
||||
|
||||
my $inc = Test::File::ShareDir::Object::Inc->new();
|
||||
|
||||
$inc->tempdir() # add files to here
|
||||
|
||||
$inc->module_tempdir() # or here
|
||||
|
||||
$inc->dist_tempdir() # or here
|
||||
|
||||
$inc->add_to_inc;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class doesn't do very much on its own.
|
||||
|
||||
It simply exists to facilitate C<tempdir> creation,
|
||||
and the injection of those C<tempdir>'s into C<@INC>
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<add_to_inc>
|
||||
|
||||
B<DEPRECATED:> Use C<register> instead.
|
||||
|
||||
=head2 C<register>
|
||||
|
||||
$instance->register;
|
||||
|
||||
Allows this C<Inc> to be used.
|
||||
|
||||
Presently, this injects the associated C<tempdir> into C<@INC>
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head2 C<clear>
|
||||
|
||||
$instance->clear();
|
||||
|
||||
Prevents this C<Inc> from being used.
|
||||
|
||||
Presently, this removes the C<tempdir> from C<@INC>
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<tempdir>
|
||||
|
||||
A path to a C<tempdir> of some description.
|
||||
|
||||
=head2 C<module_tempdir>
|
||||
|
||||
The C<module> C<ShareDir> base directory within the C<tempdir>
|
||||
|
||||
=head2 C<dist_tempdir>
|
||||
|
||||
The C<dist> C<ShareDir> base directory within the C<tempdir>
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir::Object::Inc",
|
||||
"interface":"class",
|
||||
"inherits":"Class::Tiny::Object"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
301
database/perl/vendor/lib/Test/File/ShareDir/Object/Module.pm
vendored
Normal file
301
database/perl/vendor/lib/Test/File/ShareDir/Object/Module.pm
vendored
Normal file
@@ -0,0 +1,301 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::Object::Module;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Object Oriented ShareDir creation for modules
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
use Class::Tiny {
|
||||
inc => sub {
|
||||
require Test::File::ShareDir::Object::Inc;
|
||||
return Test::File::ShareDir::Object::Inc->new();
|
||||
},
|
||||
modules => sub {
|
||||
return {};
|
||||
},
|
||||
root => sub {
|
||||
require Path::Tiny;
|
||||
return Path::Tiny::path(q[./])->absolute;
|
||||
},
|
||||
};
|
||||
|
||||
use Carp qw( carp );
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub __rcopy { require File::Copy::Recursive; goto \&File::Copy::Recursive::rcopy; }
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub module_names {
|
||||
my ( $self, ) = @_;
|
||||
return keys %{ $self->modules };
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub module_share_target_dir {
|
||||
my ( $self, $module ) = @_;
|
||||
|
||||
$module =~ s/::/-/msxg;
|
||||
|
||||
return $self->inc->module_tempdir->child($module);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub module_share_source_dir {
|
||||
my ( $self, $module ) = @_;
|
||||
require Path::Tiny;
|
||||
return Path::Tiny::path( $self->modules->{$module} )->absolute( $self->root );
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub install_module {
|
||||
my ( $self, $module ) = @_;
|
||||
my $source = $self->module_share_source_dir($module);
|
||||
my $target = $self->module_share_target_dir($module);
|
||||
return __rcopy( $source, $target );
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub install_all_modules {
|
||||
my ($self) = @_;
|
||||
for my $module ( $self->module_names ) {
|
||||
$self->install_module($module);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub add_to_inc {
|
||||
my ($self) = @_;
|
||||
carp 'add_to_inc deprecated since 1.001000, use register';
|
||||
return $self->register;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub register {
|
||||
my ($self) = @_;
|
||||
$self->inc->register;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub clear {
|
||||
my ($self) = @_;
|
||||
$self->inc->clear;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::Object::Module - Object Oriented ShareDir creation for modules
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::File::ShareDir::Object::Module;
|
||||
|
||||
my $dir = Test::File::ShareDir::Object::Module->new(
|
||||
root => "some/path",
|
||||
modules => {
|
||||
"Hello::Nurse" => "share/HN"
|
||||
},
|
||||
);
|
||||
|
||||
$dir->install_all_modules;
|
||||
$dir->add_to_inc;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 C<module_names>
|
||||
|
||||
my @names = $instance->module_names();
|
||||
|
||||
Returns the names of all modules listed in the C<modules> set.
|
||||
|
||||
=head2 C<module_share_target_dir>
|
||||
|
||||
my $dir = $instance->module_share_target_dir("Module::Name");
|
||||
|
||||
Returns the path where the C<ShareDir> will be created for C<Module::Name>
|
||||
|
||||
=head2 C<module_share_source_dir>
|
||||
|
||||
my $dir = $instance->module_share_source_dir("Module::Name");
|
||||
|
||||
Returns the path where the C<ShareDir> will be B<COPIED> I<FROM> for C<Module::Name>
|
||||
|
||||
=head2 C<install_module>
|
||||
|
||||
$instance->install_module("Module::Name");
|
||||
|
||||
Installs C<Module::Name>'s C<ShareDir>
|
||||
|
||||
=head2 C<install_all_modules>
|
||||
|
||||
$instance->install_all_modules();
|
||||
|
||||
Installs all C<module_names>.
|
||||
|
||||
=head2 C<add_to_inc>
|
||||
|
||||
B<DEPRECATED:> Use C<register> instead.
|
||||
|
||||
=head2 C<register>
|
||||
|
||||
$instance->register();
|
||||
|
||||
Adds the C<Tempdir> C<ShareDir> ( C<inc> ) to the global C<@INC>
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head2 C<clear>
|
||||
|
||||
$instance->clear();
|
||||
|
||||
Removes the C<Tempdir> C<ShareDir> ( C<inc> ) from the global C<@INC>
|
||||
|
||||
I<Since 1.001000>
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=head2 C<inc>
|
||||
|
||||
A C<Test::File::ShareDir::Object::Inc> object.
|
||||
|
||||
=head2 C<modules>
|
||||
|
||||
A hash of :
|
||||
|
||||
Module::Name => "relative/path"
|
||||
|
||||
=head2 C<root>
|
||||
|
||||
The origin all paths's are relative to.
|
||||
|
||||
( Defaults to C<cwd> )
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir::Object::Module",
|
||||
"interface":"class",
|
||||
"inherits":"Class::Tiny::Object"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
206
database/perl/vendor/lib/Test/File/ShareDir/TempDirObject.pm
vendored
Normal file
206
database/perl/vendor/lib/Test/File/ShareDir/TempDirObject.pm
vendored
Normal file
@@ -0,0 +1,206 @@
|
||||
use 5.006; # pragmas
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::TempDirObject;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
# ABSTRACT: Internal Object to make code simpler.
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
use Path::Tiny qw(path);
|
||||
use Carp qw(confess);
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
sub __rcopy { require File::Copy::Recursive; goto \&File::Copy::Recursive::rcopy; }
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub new {
|
||||
my ( $class, $config ) = @_;
|
||||
|
||||
confess('Need -share => for Test::File::ShareDir') unless exists $config->{-share};
|
||||
|
||||
my $realconfig = {
|
||||
root => path(q{./})->absolute, #->resolve->absolute,
|
||||
modules => {},
|
||||
dists => {},
|
||||
};
|
||||
|
||||
$realconfig->{root} = path( delete $config->{-root} )->absolute if exists $config->{-root};
|
||||
$realconfig->{modules} = delete $config->{-share}->{-module} if exists $config->{-share}->{-module};
|
||||
$realconfig->{dists} = delete $config->{-share}->{-dist} if exists $config->{-share}->{-dist};
|
||||
|
||||
confess( 'Unsupported -share types : ' . join q{ }, keys %{ $config->{-share} } ) if keys %{ $config->{-share} };
|
||||
|
||||
delete $config->{-share};
|
||||
|
||||
confess( 'Unsupported parameter to import() : ' . join q{ }, keys %{$config} ) if keys %{$config};
|
||||
|
||||
return bless $realconfig, $class;
|
||||
}
|
||||
|
||||
my @cache;
|
||||
|
||||
sub _tempdir {
|
||||
my ($self) = shift;
|
||||
return $self->{tempdir} if exists $self->{tempdir};
|
||||
$self->{tempdir} = Path::Tiny::tempdir( CLEANUP => 1 );
|
||||
|
||||
# Explicit keepalive till GC
|
||||
push @cache, $self->{tempdir};
|
||||
return $self->{tempdir};
|
||||
}
|
||||
|
||||
sub _module_tempdir {
|
||||
my ($self) = shift;
|
||||
return $self->{module_tempdir} if exists $self->{module_tempdir};
|
||||
$self->{module_tempdir} = $self->_tempdir->child('auto/share/module');
|
||||
$self->{module_tempdir}->mkpath();
|
||||
return $self->{module_tempdir}->absolute;
|
||||
}
|
||||
|
||||
sub _dist_tempdir {
|
||||
my ($self) = shift;
|
||||
return $self->{dist_tempdir} if exists $self->{dist_tempdir};
|
||||
$self->{dist_tempdir} = $self->_tempdir->child('auto/share/dist');
|
||||
$self->{dist_tempdir}->mkpath();
|
||||
return $self->{dist_tempdir}->absolute;
|
||||
}
|
||||
|
||||
sub _root {
|
||||
my ($self) = shift;
|
||||
return $self->{root};
|
||||
}
|
||||
|
||||
sub _modules { return shift->{modules}; }
|
||||
|
||||
sub _dists { return shift->{dists} }
|
||||
|
||||
sub _module_names {
|
||||
my ($self) = shift;
|
||||
return keys %{ $self->_modules };
|
||||
}
|
||||
|
||||
sub _dist_names {
|
||||
my ($self) = shift;
|
||||
return keys %{ $self->_dists };
|
||||
}
|
||||
|
||||
sub _module_share_target_dir {
|
||||
my ( $self, $modname ) = @_;
|
||||
|
||||
## no critic (RegularExpressions)
|
||||
$modname =~ s/::/-/g;
|
||||
|
||||
return $self->_module_tempdir->child($modname);
|
||||
}
|
||||
|
||||
sub _dist_share_target_dir {
|
||||
my ( $self, $distname ) = @_;
|
||||
return $self->_dist_tempdir->child($distname);
|
||||
}
|
||||
|
||||
sub _module_share_source_dir {
|
||||
my ( $self, $module ) = @_;
|
||||
return path( $self->_modules->{$module} )->absolute( $self->_root );
|
||||
}
|
||||
|
||||
sub _dist_share_source_dir {
|
||||
my ( $self, $dist ) = @_;
|
||||
return path( $self->_dists->{$dist} )->absolute( $self->_root );
|
||||
}
|
||||
|
||||
sub _install_module {
|
||||
my ( $self, $module ) = @_;
|
||||
return __rcopy( $self->_module_share_source_dir($module), $self->_module_share_target_dir($module) );
|
||||
}
|
||||
|
||||
sub _install_dist {
|
||||
my ( $self, $dist ) = @_;
|
||||
return __rcopy( $self->_dist_share_source_dir($dist), $self->_dist_share_target_dir($dist) );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::TempDirObject - Internal Object to make code simpler.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $object = $class->new({
|
||||
-root => 'foo', # optional
|
||||
-share => {
|
||||
-module => {
|
||||
'baz' => 'dir',
|
||||
},
|
||||
-dist => {
|
||||
'Task-baz' => 'otherdir',
|
||||
},
|
||||
},
|
||||
});
|
||||
|
||||
# installs a sharedir for 'baz' by copying 'foo/dir'
|
||||
$object->_install_module('baz');
|
||||
|
||||
# installs a shardir for distribution 'Task-baz' by copying 'foo/otherdir'
|
||||
$object->_install_dist('Task-baz');
|
||||
|
||||
# add to @INC
|
||||
unshift @INC, $object->_tempdir->stringify;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
Creates a new instance of this object.
|
||||
|
||||
=begin MetaPOD::JSON v1.1.0
|
||||
|
||||
{
|
||||
"namespace":"Test::File::ShareDir::TempDirObject",
|
||||
"interface":"class"
|
||||
}
|
||||
|
||||
|
||||
=end MetaPOD::JSON
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
115
database/perl/vendor/lib/Test/File/ShareDir/Utils.pm
vendored
Normal file
115
database/perl/vendor/lib/Test/File/ShareDir/Utils.pm
vendored
Normal file
@@ -0,0 +1,115 @@
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::File::ShareDir::Utils;
|
||||
|
||||
our $VERSION = '1.001002';
|
||||
|
||||
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
|
||||
|
||||
# ABSTRACT: Simple utilities for File::ShareDir testing
|
||||
|
||||
use Exporter 5.57 qw(import);
|
||||
use Carp qw( croak );
|
||||
|
||||
our @EXPORT_OK = qw( extract_dashes );
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub extract_dashes {
|
||||
my ( $undashed_to, $source ) = @_;
|
||||
if ( not ref $source or 'HASH' ne ref $source ) {
|
||||
return croak(q[Must pass a hashref]);
|
||||
}
|
||||
my %input_config = %{$source};
|
||||
my $params = {};
|
||||
for my $key ( keys %input_config ) {
|
||||
next unless $key =~ /\A-(.*)\z/msx;
|
||||
$params->{$1} = delete $input_config{$key};
|
||||
}
|
||||
$params->{$undashed_to} = {} if not exists $params->{$undashed_to};
|
||||
for my $key ( keys %input_config ) {
|
||||
$params->{$undashed_to}->{$key} = $input_config{$key};
|
||||
}
|
||||
return $params;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::File::ShareDir::Utils - Simple utilities for File::ShareDir testing
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.001002
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::File::ShareDir::Utils qw( extract_dashes );
|
||||
|
||||
my $hash = extract_dashes('dists', $oldhash );
|
||||
|
||||
=head1 EXPORTABLE FUNCTIONS
|
||||
|
||||
=head2 extract_dashes
|
||||
|
||||
A utility that helps transform:
|
||||
|
||||
-opt_a => bar
|
||||
-opt_b => baz
|
||||
NameA => NameAValue
|
||||
NameB => NameBValue
|
||||
|
||||
Into
|
||||
|
||||
opt_a => bar
|
||||
opt_b => baz
|
||||
modules => {
|
||||
NameA => NameAValue
|
||||
NameB => NameBValue
|
||||
}
|
||||
|
||||
This is a useful approach used all over import and functional style interfaces due to explicit configuration
|
||||
being needed only on rare occasions.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Kent Fredric <kentnl@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
|
||||
|
||||
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
|
||||
191
database/perl/vendor/lib/Test/Fork.pm
vendored
Normal file
191
database/perl/vendor/lib/Test/Fork.pm
vendored
Normal file
@@ -0,0 +1,191 @@
|
||||
package Test::Fork;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.02';
|
||||
|
||||
use base 'Test::Builder::Module';
|
||||
our @EXPORT = qw(fork_ok);
|
||||
|
||||
my $CLASS = __PACKAGE__;
|
||||
|
||||
|
||||
sub note {
|
||||
my $msg = shift;
|
||||
my $fh = $CLASS->builder->output;
|
||||
|
||||
print $fh "# $msg\n";
|
||||
}
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Fork - test code which forks
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::More tests => 4;
|
||||
use Test::Fork;
|
||||
|
||||
fork_ok(2, sub{
|
||||
pass("Test in the child process");
|
||||
pass("Another test in the child process");
|
||||
});
|
||||
|
||||
pass("Test in the parent");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<THIS IS ALPHA CODE!> The implementation is unreliable and the interface
|
||||
is subject to change.
|
||||
|
||||
Because each test has a number associated with it, testing code which forks
|
||||
is problematic. Coordinating the test number amongst the parent and child
|
||||
processes is complicated. Test::Fork provides a function to smooth over
|
||||
the complications.
|
||||
|
||||
=head2 Functions
|
||||
|
||||
Each function is exported by default.
|
||||
|
||||
=head3 B<fork_ok>
|
||||
|
||||
my $child_pid = fork_ok( $num_tests, sub {
|
||||
...child test code...
|
||||
});
|
||||
|
||||
Runs the given child test code in a forked process. Returns the pid of the
|
||||
forked child process, or false if the fork fails.
|
||||
|
||||
$num_tests is the number of tests in your child test code.
|
||||
Consider it to be a sub-plan.
|
||||
|
||||
fork_ok() itself is a test, if the fork fails it will fail. fork_ok()
|
||||
test does not count towards your $num_tests.
|
||||
|
||||
# This is three tests.
|
||||
fork_ok( 2, sub {
|
||||
is $foo, $bar;
|
||||
ok Something->method;
|
||||
});
|
||||
|
||||
The children are automatically reaped.
|
||||
|
||||
=cut
|
||||
|
||||
my %Reaped;
|
||||
my %Running_Children;
|
||||
my $Is_Child = 0;
|
||||
|
||||
sub fork_ok ($&) {
|
||||
my($num_tests, $child_sub) = @_;
|
||||
|
||||
my $tb = $CLASS->builder;
|
||||
my $pid = fork;
|
||||
|
||||
# Failed fork
|
||||
if( !defined $pid ) {
|
||||
return $tb->ok(0, "fork() failed: $!");
|
||||
}
|
||||
# Parent
|
||||
elsif( $pid ) {
|
||||
# Avoid race condition where child has run and is reaped before
|
||||
# parent even runs.
|
||||
$Running_Children{$pid} = 1 unless $Reaped{$pid};
|
||||
|
||||
$tb->use_numbers(0);
|
||||
$tb->current_test($tb->current_test + $num_tests);
|
||||
|
||||
$tb->ok(1, "fork() succeeded, child pid $pid");
|
||||
return $pid;
|
||||
}
|
||||
|
||||
# Child
|
||||
$Is_Child = 1;
|
||||
|
||||
$tb->use_numbers(0);
|
||||
$tb->no_ending(1);
|
||||
|
||||
note("Running child pid $$");
|
||||
$child_sub->();
|
||||
exit;
|
||||
}
|
||||
|
||||
END {
|
||||
while( !$Is_Child and keys %Running_Children ) {
|
||||
note("reaper($$) waiting on @{[keys %Running_Children]}");
|
||||
_check_kids();
|
||||
_reaper();
|
||||
}
|
||||
}
|
||||
|
||||
sub _check_kids {
|
||||
for my $child (keys %Running_Children) {
|
||||
delete $Running_Children{$child} if $Reaped{$child};
|
||||
delete $Running_Children{$child} unless kill 0, $child;
|
||||
note("Child $child already reaped");
|
||||
}
|
||||
}
|
||||
|
||||
sub _reaper {
|
||||
local $?; # wait sets $?
|
||||
|
||||
my $child_pid = wait;
|
||||
$Reaped{$child_pid}++;
|
||||
delete $Running_Children{$child_pid};
|
||||
|
||||
note("child $child_pid reaped");
|
||||
|
||||
$CLASS->builder->use_numbers(1) unless keys %Running_Children;
|
||||
|
||||
return $child_pid == -1 ? 0 : 1;
|
||||
}
|
||||
|
||||
$SIG{CHLD} = \&_reaper;
|
||||
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
The failure of tests in a child process cannot be detected by the parent.
|
||||
Therefore, the normal end-of-test reporting done by Test::Builder will
|
||||
not notice failed child tests.
|
||||
|
||||
Test::Fork turns off test numbering in order to avoid test counter
|
||||
coordination issues. It turns it back on once the children are done
|
||||
running.
|
||||
|
||||
Test::Fork will wait for all your child processes to complete at the end of
|
||||
the parent process.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test::MultiFork>
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Michael G Schwern E<lt>schwern@pobox.comE<gt>
|
||||
|
||||
|
||||
=head1 BUGS and FEEDBACK
|
||||
|
||||
Please send all bugs and feature requests to
|
||||
I<bug-Test-Fork> at I<rt.cpan.org> or use the web interface via
|
||||
L<http://rt.cpan.org>.
|
||||
|
||||
If you use it, please send feedback. I like getting feedback.
|
||||
|
||||
|
||||
=head1 COPYRIGHT and LICENSE
|
||||
|
||||
Copyright 2007-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See F<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=cut
|
||||
|
||||
42;
|
||||
266
database/perl/vendor/lib/Test/MockTime.pm
vendored
Normal file
266
database/perl/vendor/lib/Test/MockTime.pm
vendored
Normal file
@@ -0,0 +1,266 @@
|
||||
package Test::MockTime;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp();
|
||||
use Exporter();
|
||||
*import = \&Exporter::import;
|
||||
our @EXPORT_OK = qw(
|
||||
set_relative_time
|
||||
set_absolute_time
|
||||
set_fixed_time
|
||||
restore_time
|
||||
);
|
||||
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK, );
|
||||
our $VERSION = '0.17';
|
||||
our $offset = 0;
|
||||
our $fixed = undef;
|
||||
|
||||
BEGIN {
|
||||
*CORE::GLOBAL::time = \&Test::MockTime::time;
|
||||
*CORE::GLOBAL::localtime = \&Test::MockTime::localtime;
|
||||
*CORE::GLOBAL::gmtime = \&Test::MockTime::gmtime;
|
||||
}
|
||||
|
||||
sub set_relative_time {
|
||||
my ($relative) = @_;
|
||||
if ( ( $relative eq __PACKAGE__ )
|
||||
|| ( UNIVERSAL::isa( $relative, __PACKAGE__ ) ) )
|
||||
{
|
||||
Carp::carp("Test::MockTime::set_relative_time called incorrectly\n");
|
||||
}
|
||||
$offset = $_[-1]; # last argument. might have been called in a OO syntax?
|
||||
return $offset;
|
||||
}
|
||||
|
||||
sub _time {
|
||||
my ( $time, $spec ) = @_;
|
||||
if ( $time !~ /\A -? \d+ \z/xms ) {
|
||||
$spec ||= '%Y-%m-%dT%H:%M:%SZ';
|
||||
}
|
||||
if ($spec) {
|
||||
require Time::Piece;
|
||||
$time = Time::Piece->strptime( $time, $spec )->epoch();
|
||||
}
|
||||
return $time;
|
||||
}
|
||||
|
||||
sub set_absolute_time {
|
||||
my ( $time, $spec ) = @_;
|
||||
if ( ( $time eq __PACKAGE__ ) || ( UNIVERSAL::isa( $time, __PACKAGE__ ) ) )
|
||||
{
|
||||
Carp::carp("Test::MockTime::set_absolute_time called incorrectly\n");
|
||||
}
|
||||
$time = _time( $time, $spec );
|
||||
$offset = $time - CORE::time;
|
||||
return $offset;
|
||||
}
|
||||
|
||||
sub set_fixed_time {
|
||||
my ( $time, $spec ) = @_;
|
||||
if ( ( $time eq __PACKAGE__ ) || ( UNIVERSAL::isa( $time, __PACKAGE__ ) ) )
|
||||
{
|
||||
Carp::carp("Test::MockTime::set_fixed_time called incorrectly\n");
|
||||
}
|
||||
$time = _time( $time, $spec );
|
||||
$fixed = $time;
|
||||
return $fixed;
|
||||
}
|
||||
|
||||
sub time() {
|
||||
if ( defined $fixed ) {
|
||||
return $fixed;
|
||||
}
|
||||
else {
|
||||
return ( CORE::time + $offset );
|
||||
}
|
||||
}
|
||||
|
||||
sub localtime (;$) {
|
||||
my ($time) = @_;
|
||||
if ( !defined $time ) {
|
||||
$time = Test::MockTime::time();
|
||||
}
|
||||
return CORE::localtime($time);
|
||||
}
|
||||
|
||||
sub gmtime (;$) {
|
||||
my ($time) = @_;
|
||||
if ( !defined $time ) {
|
||||
$time = Test::MockTime::time();
|
||||
}
|
||||
return CORE::gmtime($time);
|
||||
}
|
||||
|
||||
sub restore {
|
||||
$offset = 0;
|
||||
$fixed = undef;
|
||||
return;
|
||||
}
|
||||
*restore_time = \&restore;
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::MockTime - Replaces actual time with simulated time
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 0.17
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::MockTime qw( :all );
|
||||
set_relative_time(-600);
|
||||
|
||||
# do some tests depending on time increasing from 600 seconds ago
|
||||
|
||||
set_absolute_time(0);
|
||||
|
||||
# do some more tests depending on time starting from the epoch
|
||||
# epoch may vary according to platform. see perlport.
|
||||
|
||||
set_fixed_time(CORE::time());
|
||||
|
||||
# do some more tests depending on time staying at the current actual time
|
||||
|
||||
set_absolute_time('1970-01-01T00:00:00Z');
|
||||
|
||||
# do some tests depending on time starting at Unix epoch time
|
||||
|
||||
set_fixed_time('01/01/1970 00:00:00', '%m/%d/%Y %H:%M:%S');
|
||||
|
||||
# do some tests depending on time staying at the Unix epoch time
|
||||
|
||||
restore_time();
|
||||
|
||||
# resume normal service
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module was created to enable test suites to test code at specific
|
||||
points in time. Specifically it overrides localtime, gmtime and time at
|
||||
compile time and then relies on the user supplying a mock time via
|
||||
set_relative_time, set_absolute_time or set_fixed_time to alter future
|
||||
calls to gmtime,time or localtime.
|
||||
|
||||
=head1 SUBROUTINES/METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item set_absolute_time
|
||||
|
||||
If given a single, numeric argument, the argument is an absolute time (for
|
||||
example, if 0 is supplied, the absolute time will be the epoch), and
|
||||
calculates the offset to allow subsequent calls to time, gmtime and localtime
|
||||
to reflect this.
|
||||
|
||||
for example, in the following code
|
||||
|
||||
Test::MockTime::set_absolute_time(0);
|
||||
my ($start) = time;
|
||||
sleep 2;
|
||||
my ($end) = time;
|
||||
|
||||
The $end variable should contain 2 seconds past the epoch;
|
||||
|
||||
If given two arguments, the first argument is taken to be an absolute time in
|
||||
some string format (for example, "01/01/1970 00:00:00"). The second argument
|
||||
is taken to be a C<strptime> format string (for example, "%m/%d/%Y %H:%M:%S").
|
||||
If a single argument is given, but that argument is not numeric, a
|
||||
C<strptime> format string of "%Y-%m-%dT%H:%M:%SZ" is assumed.
|
||||
|
||||
for example, in the following code
|
||||
|
||||
Test::MockTime::set_absolute_time('1970-01-01T00:00:00Z');
|
||||
my ($start) = time;
|
||||
sleep 2;
|
||||
my ($end) = time;
|
||||
|
||||
The $end variable should contain 2 seconds past the Unix epoch;
|
||||
|
||||
=item set_relative_time($relative)
|
||||
|
||||
takes as an argument an relative value from current time (for example, if -10
|
||||
is supplied, current time be converted to actual machine time - 10 seconds)
|
||||
and calculates the offset to allow subsequent calls to time,gmtime and localtime
|
||||
to reflect this.
|
||||
|
||||
for example, in the following code
|
||||
|
||||
my ($start) = time;
|
||||
Test::MockTime::set_relative_time(-600);
|
||||
sleep 600;
|
||||
my ($end) = time;
|
||||
|
||||
The $end variable should contain either the same or very similar values to the
|
||||
$start variable.
|
||||
|
||||
=item set_fixed_time
|
||||
|
||||
If given a single, numeric argument, the argument is an absolute time (for
|
||||
example, if 0 is supplied, the absolute time will be the epoch). All
|
||||
subsequent calls to gmtime, localtime and time will return this value.
|
||||
|
||||
for example, in the following code
|
||||
|
||||
Test::MockTime::set_fixed_time(time)
|
||||
my ($start) = time;
|
||||
sleep 3;
|
||||
my ($end) = time;
|
||||
|
||||
the $end variable and the $start variable will contain the same results
|
||||
|
||||
If given two arguments, the first argument is taken to be an absolute time in
|
||||
some string format (for example, "01/01/1970 00:00:00"). The second argument
|
||||
is taken to be a C<strptime> format string (for example, "%m/%d/%Y %H:%M:%S").
|
||||
If a single argument is given, but that argument is not numeric, a
|
||||
C<strptime> format string of "%Y-%m-%dT%H:%M:%SZ" is assumed.
|
||||
|
||||
=item restore()
|
||||
|
||||
restore the default time handling values. C<restore_time> is an alias. When
|
||||
exported with the 'all' tag, this subroutine is exported as C<restore_time>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CONFIGURATION AND ENVIRONMENT
|
||||
|
||||
Test::MockTime requires no configuration files or environment variables.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
Test::MockTime depends on the following non-core Perl modules.
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
L<Time::Piece 1.08 or greater|Time::Piece>
|
||||
|
||||
=back
|
||||
|
||||
=head1 INCOMPATIBILITIES
|
||||
|
||||
None reported
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
Probably.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Dick <ddick@cpan.org>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
Thanks to a use.perl.org journal entry <http://use.perl.org/~geoff/journal/20660> by
|
||||
Geoffrey Young.
|
||||
1132
database/perl/vendor/lib/Test/Mojo.pm
vendored
Normal file
1132
database/perl/vendor/lib/Test/Mojo.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
228
database/perl/vendor/lib/Test/Moose.pm
vendored
Normal file
228
database/perl/vendor/lib/Test/Moose.pm
vendored
Normal file
@@ -0,0 +1,228 @@
|
||||
package Test::Moose;
|
||||
our $VERSION = '2.2014';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sub::Exporter;
|
||||
use Test::Builder;
|
||||
|
||||
use List::Util 1.33 'all';
|
||||
use Moose::Util 'does_role', 'find_meta';
|
||||
|
||||
my @exports = qw[
|
||||
meta_ok
|
||||
does_ok
|
||||
has_attribute_ok
|
||||
with_immutable
|
||||
];
|
||||
|
||||
Sub::Exporter::setup_exporter({
|
||||
exports => \@exports,
|
||||
groups => { default => \@exports }
|
||||
});
|
||||
|
||||
## the test builder instance ...
|
||||
|
||||
my $Test = Test::Builder->new;
|
||||
|
||||
## exported functions
|
||||
|
||||
sub meta_ok ($;$) {
|
||||
my ($class_or_obj, $message) = @_;
|
||||
|
||||
$message ||= "The object has a meta";
|
||||
|
||||
if (find_meta($class_or_obj)) {
|
||||
return $Test->ok(1, $message)
|
||||
}
|
||||
else {
|
||||
return $Test->ok(0, $message);
|
||||
}
|
||||
}
|
||||
|
||||
sub does_ok ($$;$) {
|
||||
my ($class_or_obj, $does, $message) = @_;
|
||||
|
||||
$message ||= "The object does $does";
|
||||
|
||||
if (does_role($class_or_obj, $does)) {
|
||||
return $Test->ok(1, $message)
|
||||
}
|
||||
else {
|
||||
return $Test->ok(0, $message);
|
||||
}
|
||||
}
|
||||
|
||||
sub has_attribute_ok ($$;$) {
|
||||
my ($class_or_obj, $attr_name, $message) = @_;
|
||||
|
||||
$message ||= "The object does has an attribute named $attr_name";
|
||||
|
||||
my $meta = find_meta($class_or_obj);
|
||||
|
||||
if ($meta->find_attribute_by_name($attr_name)) {
|
||||
return $Test->ok(1, $message)
|
||||
}
|
||||
else {
|
||||
return $Test->ok(0, $message);
|
||||
}
|
||||
}
|
||||
|
||||
sub with_immutable (&@) {
|
||||
my $block = shift;
|
||||
my $before = $Test->current_test;
|
||||
|
||||
$block->(0);
|
||||
Class::MOP::class_of($_)->make_immutable for @_;
|
||||
$block->(1);
|
||||
|
||||
my $num_tests = $Test->current_test - $before;
|
||||
my $all_passed = all { $_ } ($Test->summary)[-$num_tests..-1];
|
||||
return $all_passed;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: Test functions for Moose specific features
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Moose - Test functions for Moose specific features
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2014
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::More plan => 1;
|
||||
use Test::Moose;
|
||||
|
||||
meta_ok($class_or_obj, "... Foo has a ->meta");
|
||||
does_ok($class_or_obj, $role, "... Foo does the Baz role");
|
||||
has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some useful test functions for Moose based classes. It
|
||||
is an experimental first release, so comments and suggestions are very welcome.
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
=head2 meta_ok ($class_or_object)
|
||||
|
||||
Tests if a class or object has a metaclass.
|
||||
|
||||
=head2 does_ok ($class_or_object, $role, ?$message)
|
||||
|
||||
Tests if a class or object does a certain role, similar to what C<isa_ok>
|
||||
does for the C<isa> method.
|
||||
|
||||
=head2 has_attribute_ok($class_or_object, $attr_name, ?$message)
|
||||
|
||||
Tests if a class or object has a certain attribute, similar to what C<can_ok>
|
||||
does for the methods.
|
||||
|
||||
=head2 with_immutable { CODE } @class_names
|
||||
|
||||
Runs B<CODE> (which should contain normal tests) twice, and make each
|
||||
class in C<@class_names> immutable in between the two runs.
|
||||
|
||||
The B<CODE> block is called with a single boolean argument indicating whether
|
||||
or not the classes have been made immutable yet.
|
||||
|
||||
=head1 TODO
|
||||
|
||||
=over 4
|
||||
|
||||
=item Convert the Moose test suite to use this module.
|
||||
|
||||
=item Here is a list of possible functions to write
|
||||
|
||||
=over 4
|
||||
|
||||
=item immutability predicates
|
||||
|
||||
=item anon-class predicates
|
||||
|
||||
=item discovering original method from modified method
|
||||
|
||||
=item attribute metaclass predicates (attribute_isa?)
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::More>
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
See L<Moose/BUGS> for details on reporting bugs.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2006 by Infinity Interactive, Inc.
|
||||
|
||||
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
|
||||
584
database/perl/vendor/lib/Test/Number/Delta.pm
vendored
Normal file
584
database/perl/vendor/lib/Test/Number/Delta.pm
vendored
Normal file
@@ -0,0 +1,584 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::Number::Delta;
|
||||
# ABSTRACT: Compare the difference between numbers against a given tolerance
|
||||
|
||||
our $VERSION = '1.06';
|
||||
|
||||
use vars qw (@EXPORT @ISA);
|
||||
|
||||
# Required modules
|
||||
use Carp;
|
||||
use Test::Builder;
|
||||
use Exporter;
|
||||
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw( delta_not_ok delta_ok delta_within delta_not_within );
|
||||
|
||||
#pod =head1 SYNOPSIS
|
||||
#pod
|
||||
#pod # Import test functions
|
||||
#pod use Test::Number::Delta;
|
||||
#pod
|
||||
#pod # Equality test with default tolerance
|
||||
#pod delta_ok( 1e-5, 2e-5, 'values within 1e-6');
|
||||
#pod
|
||||
#pod # Inequality test with default tolerance
|
||||
#pod delta_not_ok( 1e-5, 2e-5, 'values not within 1e-6');
|
||||
#pod
|
||||
#pod # Provide specific tolerance
|
||||
#pod delta_within( 1e-3, 2e-3, 1e-4, 'values within 1e-4');
|
||||
#pod delta_not_within( 1e-3, 2e-3, 1e-4, 'values not within 1e-4');
|
||||
#pod
|
||||
#pod # Compare arrays or matrices
|
||||
#pod @a = ( 3.14, 1.41 );
|
||||
#pod @b = ( 3.15, 1.41 );
|
||||
#pod delta_ok( \@a, \@b, 'compare @a and @b' );
|
||||
#pod
|
||||
#pod # Set a different default tolerance
|
||||
#pod use Test::Number::Delta within => 1e-5;
|
||||
#pod delta_ok( 1.1e-5, 2e-5, 'values within 1e-5'); # ok
|
||||
#pod
|
||||
#pod # Set a relative tolerance
|
||||
#pod use Test::Number::Delta relative => 1e-3;
|
||||
#pod delta_ok( 1.01, 1.0099, 'values within 1.01e-3');
|
||||
#pod
|
||||
#pod
|
||||
#pod =head1 DESCRIPTION
|
||||
#pod
|
||||
#pod At some point or another, most programmers find they need to compare
|
||||
#pod floating-point numbers for equality. The typical idiom is to test
|
||||
#pod if the absolute value of the difference of the numbers is within a desired
|
||||
#pod tolerance, usually called epsilon. This module provides such a function for use
|
||||
#pod with L<Test::More>. Usage is similar to other test functions described in
|
||||
#pod L<Test::More>. Semantically, the C<delta_within> function replaces this kind
|
||||
#pod of construct:
|
||||
#pod
|
||||
#pod ok ( abs($p - $q) < $epsilon, '$p is equal to $q' ) or
|
||||
#pod diag "$p is not equal to $q to within $epsilon";
|
||||
#pod
|
||||
#pod While there's nothing wrong with that construct, it's painful to type it
|
||||
#pod repeatedly in a test script. This module does the same thing with a single
|
||||
#pod function call. The C<delta_ok> function is similar, but either uses a global
|
||||
#pod default value for epsilon or else calculates a 'relative' epsilon on
|
||||
#pod the fly so that epsilon is scaled automatically to the size of the arguments to
|
||||
#pod C<delta_ok>. Both functions are exported automatically.
|
||||
#pod
|
||||
#pod Because checking floating-point equality is not always reliable, it is not
|
||||
#pod possible to check the 'equal to' boundary of 'less than or equal to
|
||||
#pod epsilon'. Therefore, Test::Number::Delta only compares if the absolute value
|
||||
#pod of the difference is B<less than> epsilon (for equality tests) or
|
||||
#pod B<greater than> epsilon (for inequality tests).
|
||||
#pod
|
||||
#pod =head1 USAGE
|
||||
#pod
|
||||
#pod =head2 use Test::Number::Delta;
|
||||
#pod
|
||||
#pod With no arguments, epsilon defaults to 1e-6. (An arbitrary choice on the
|
||||
#pod author's part.)
|
||||
#pod
|
||||
#pod =head2 use Test::Number::Delta within => 1e-9;
|
||||
#pod
|
||||
#pod To specify a different default value for epsilon, provide a C<within> parameter
|
||||
#pod when importing the module. The value must be non-zero.
|
||||
#pod
|
||||
#pod =head2 use Test::Number::Delta relative => 1e-3;
|
||||
#pod
|
||||
#pod As an alternative to using a fixed value for epsilon, provide a C<relative>
|
||||
#pod parameter when importing the module. This signals that C<delta_ok> should
|
||||
#pod test equality with an epsilon that is scaled to the size of the arguments.
|
||||
#pod Epsilon is calculated as the relative value times the absolute value
|
||||
#pod of the argument with the greatest magnitude. Mathematically, for arguments
|
||||
#pod 'x' and 'y':
|
||||
#pod
|
||||
#pod epsilon = relative * max( abs(x), abs(y) )
|
||||
#pod
|
||||
#pod For example, a relative value of "0.01" would mean that the arguments are equal
|
||||
#pod if they differ by less than 1% of the larger of the two values. A relative
|
||||
#pod value of 1e-6 means that the arguments must differ by less than 1 millionth
|
||||
#pod of the larger value. The relative value must be non-zero.
|
||||
#pod
|
||||
#pod =head2 Combining with a test plan
|
||||
#pod
|
||||
#pod use Test::Number::Delta 'no_plan';
|
||||
#pod
|
||||
#pod # or
|
||||
#pod
|
||||
#pod use Test::Number::Delta within => 1e-9, tests => 1;
|
||||
#pod
|
||||
#pod If a test plan has not already been specified, the optional
|
||||
#pod parameter for Test::Number::Delta may be followed with a test plan (see
|
||||
#pod L<Test::More> for details). If a parameter for Test::Number::Delta is
|
||||
#pod given, it must come first.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
my $Test = Test::Builder->new;
|
||||
my $Epsilon = 1e-6;
|
||||
my $Relative = undef;
|
||||
|
||||
sub import {
|
||||
my $self = shift;
|
||||
my $pack = caller;
|
||||
my $found = grep /within|relative/, @_;
|
||||
croak "Can't specify more than one of 'within' or 'relative'"
|
||||
if $found > 1;
|
||||
if ($found) {
|
||||
my ( $param, $value ) = splice @_, 0, 2;
|
||||
croak "'$param' parameter must be non-zero"
|
||||
if $value == 0;
|
||||
if ( $param eq 'within' ) {
|
||||
$Epsilon = abs($value);
|
||||
}
|
||||
elsif ( $param eq 'relative' ) {
|
||||
$Relative = abs($value);
|
||||
}
|
||||
else {
|
||||
croak "Test::Number::Delta parameters must come first";
|
||||
}
|
||||
}
|
||||
$Test->exported_to($pack);
|
||||
$Test->plan(@_);
|
||||
$self->export_to_level( 1, $self, $_ ) for @EXPORT;
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# _check -- recursive function to perform comparison
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
sub _check {
|
||||
my ( $p, $q, $e, $name, @indices ) = @_;
|
||||
my $epsilon;
|
||||
|
||||
if ( !defined $e ) {
|
||||
$epsilon =
|
||||
$Relative
|
||||
? $Relative * ( abs($p) > abs($q) ? abs($p) : abs($q) )
|
||||
: $Epsilon;
|
||||
}
|
||||
else {
|
||||
$epsilon = abs($e);
|
||||
}
|
||||
|
||||
my ( $ok, $diag ) = ( 1, q{} ); # assume true
|
||||
if ( ref $p eq 'ARRAY' || ref $q eq 'ARRAY' ) {
|
||||
if ( @$p == @$q ) {
|
||||
for my $i ( 0 .. $#{$p} ) {
|
||||
my @new_indices;
|
||||
( $ok, $diag, @new_indices ) =
|
||||
_check( $p->[$i], $q->[$i], $e, $name, scalar @indices ? @indices : (), $i, );
|
||||
if ( not $ok ) {
|
||||
@indices = @new_indices;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$ok = 0;
|
||||
$diag =
|
||||
"Got an array of length "
|
||||
. scalar(@$p)
|
||||
. ", but expected an array of length "
|
||||
. scalar(@$q);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$ok = $p == $q || abs( $p - $q ) < $epsilon;
|
||||
if ( !$ok ) {
|
||||
my ( $ep, $dp ) = _ep_dp($epsilon);
|
||||
$diag = sprintf( "%.${dp}f and %.${dp}f are not equal" . " to within %.${ep}f",
|
||||
$p, $q, $epsilon );
|
||||
}
|
||||
}
|
||||
return ( $ok, $diag, scalar(@indices) ? @indices : () );
|
||||
}
|
||||
|
||||
sub _ep_dp {
|
||||
my $epsilon = shift;
|
||||
return ( 0, 0 ) unless $epsilon;
|
||||
$epsilon = abs($epsilon);
|
||||
my ($exp) = sprintf( "%e", $epsilon ) =~ m/e(.+)/;
|
||||
my $ep = $exp < 0 ? -$exp : 1;
|
||||
my $dp = $ep + 1;
|
||||
return ( $ep, $dp );
|
||||
}
|
||||
|
||||
sub _diag_default {
|
||||
my ($ep) = _ep_dp( abs( $Relative || $Epsilon ) );
|
||||
my $diag = "Arguments are equal to within ";
|
||||
$diag .=
|
||||
$Relative
|
||||
? sprintf( "relative tolerance %.${ep}f", abs($Relative) )
|
||||
: sprintf( "%.${ep}f", abs($Epsilon) );
|
||||
return $diag;
|
||||
}
|
||||
|
||||
#pod =head1 FUNCTIONS
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# delta_within()
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
#pod =head2 delta_within
|
||||
#pod
|
||||
#pod delta_within( $p, $q, $epsilon, '$p and $q are equal within $epsilon' );
|
||||
#pod delta_within( \@p, \@q, $epsilon, '@p and @q are equal within $epsilon' );
|
||||
#pod
|
||||
#pod This function tests for equality within a given value of epsilon. The test is
|
||||
#pod true if the absolute value of the difference between $p and $q is B<less than>
|
||||
#pod epsilon. If the test is true, it prints an "OK" statement for use in testing.
|
||||
#pod If the test is not true, this function prints a failure report and diagnostic.
|
||||
#pod Epsilon must be non-zero.
|
||||
#pod
|
||||
#pod The values to compare may be scalars or references to arrays. If the values
|
||||
#pod are references to arrays, the comparison is done pairwise for each index value
|
||||
#pod of the array. The pairwise comparison is recursive, so matrices may
|
||||
#pod be compared as well.
|
||||
#pod
|
||||
#pod For example, this code sample compares two matrices:
|
||||
#pod
|
||||
#pod my @a = ( [ 3.14, 6.28 ],
|
||||
#pod [ 1.41, 2.84 ] );
|
||||
#pod
|
||||
#pod my @b = ( [ 3.14, 6.28 ],
|
||||
#pod [ 1.42, 2.84 ] );
|
||||
#pod
|
||||
#pod delta_within( \@a, \@b, 1e-6, 'compare @a and @b' );
|
||||
#pod
|
||||
#pod The sample prints the following:
|
||||
#pod
|
||||
#pod not ok 1 - compare @a and @b
|
||||
#pod # At [1][0]: 1.4100000 and 1.4200000 are not equal to within 0.000001
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub delta_within($$$;$) { ## no critic
|
||||
my ( $p, $q, $epsilon, $name ) = @_;
|
||||
croak "Value of epsilon to delta_within must be non-zero"
|
||||
if !defined($epsilon) || $epsilon == 0;
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
_delta_within( $p, $q, $epsilon, $name );
|
||||
}
|
||||
}
|
||||
|
||||
sub _delta_within {
|
||||
my ( $p, $q, $epsilon, $name ) = @_;
|
||||
my ( $ok, $diag, @indices ) = _check( $p, $q, $epsilon, $name );
|
||||
if (@indices) {
|
||||
$diag = "At [" . join( "][", @indices ) . "]: $diag";
|
||||
}
|
||||
return $Test->ok( $ok, $name ) || $Test->diag($diag);
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# delta_ok()
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
#pod =head2 delta_ok
|
||||
#pod
|
||||
#pod delta_ok( $p, $q, '$p and $q are close enough to equal' );
|
||||
#pod delta_ok( \@p, \@q, '@p and @q are close enough to equal' );
|
||||
#pod
|
||||
#pod This function tests for equality within a default epsilon value. See L</USAGE>
|
||||
#pod for details on changing the default. Otherwise, this function works the same
|
||||
#pod as C<delta_within>.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub delta_ok($$;$) { ## no critic
|
||||
my ( $p, $q, $name ) = @_;
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
_delta_within( $p, $q, undef, $name );
|
||||
}
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# delta_not_ok()
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
#pod =head2 delta_not_within
|
||||
#pod
|
||||
#pod delta_not_within( $p, $q, '$p and $q are different' );
|
||||
#pod delta_not_within( \@p, \@q, $epsilon, '@p and @q are different' );
|
||||
#pod
|
||||
#pod This test compares inequality in excess of a given value of epsilon. The test
|
||||
#pod is true if the absolute value of the difference between $p and $q is B<greater
|
||||
#pod than> epsilon. For array or matrix comparisons, the test is true if I<any>
|
||||
#pod pair of values differs by more than epsilon. Otherwise, this function works
|
||||
#pod the same as C<delta_within>.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub delta_not_within($$$;$) { ## no critic
|
||||
my ( $p, $q, $epsilon, $name ) = @_;
|
||||
croak "Value of epsilon to delta_not_within must be non-zero"
|
||||
if !defined($epsilon) || $epsilon == 0;
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
_delta_not_within( $p, $q, $epsilon, $name );
|
||||
}
|
||||
}
|
||||
|
||||
sub _delta_not_within($$$;$) { ## no critic
|
||||
my ( $p, $q, $epsilon, $name ) = @_;
|
||||
my ( $ok, undef, @indices ) = _check( $p, $q, $epsilon, $name );
|
||||
$ok = !$ok;
|
||||
my ( $ep, $dp ) = _ep_dp($epsilon);
|
||||
my $diag =
|
||||
defined($epsilon)
|
||||
? sprintf( "Arguments are equal to within %.${ep}f", abs($epsilon) )
|
||||
: _diag_default();
|
||||
return $Test->ok( $ok, $name ) || $Test->diag($diag);
|
||||
}
|
||||
|
||||
#pod =head2 delta_not_ok
|
||||
#pod
|
||||
#pod delta_not_ok( $p, $q, '$p and $q are different' );
|
||||
#pod delta_not_ok( \@p, \@q, '@p and @q are different' );
|
||||
#pod
|
||||
#pod This function tests for inequality in excess of a default epsilon value. See
|
||||
#pod L</USAGE> for details on changing the default. Otherwise, this function works
|
||||
#pod the same as C<delta_not_within>.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub delta_not_ok($$;$) { ## no critic
|
||||
my ( $p, $q, $name ) = @_;
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
_delta_not_within( $p, $q, undef, $name );
|
||||
}
|
||||
}
|
||||
|
||||
#pod =head1 SEE ALSO
|
||||
#pod
|
||||
#pod =for :list
|
||||
#pod * L<Number::Tolerant>
|
||||
#pod * L<Test::Deep::NumberTolerant>
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Number::Delta - Compare the difference between numbers against a given tolerance
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.06
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Import test functions
|
||||
use Test::Number::Delta;
|
||||
|
||||
# Equality test with default tolerance
|
||||
delta_ok( 1e-5, 2e-5, 'values within 1e-6');
|
||||
|
||||
# Inequality test with default tolerance
|
||||
delta_not_ok( 1e-5, 2e-5, 'values not within 1e-6');
|
||||
|
||||
# Provide specific tolerance
|
||||
delta_within( 1e-3, 2e-3, 1e-4, 'values within 1e-4');
|
||||
delta_not_within( 1e-3, 2e-3, 1e-4, 'values not within 1e-4');
|
||||
|
||||
# Compare arrays or matrices
|
||||
@a = ( 3.14, 1.41 );
|
||||
@b = ( 3.15, 1.41 );
|
||||
delta_ok( \@a, \@b, 'compare @a and @b' );
|
||||
|
||||
# Set a different default tolerance
|
||||
use Test::Number::Delta within => 1e-5;
|
||||
delta_ok( 1.1e-5, 2e-5, 'values within 1e-5'); # ok
|
||||
|
||||
# Set a relative tolerance
|
||||
use Test::Number::Delta relative => 1e-3;
|
||||
delta_ok( 1.01, 1.0099, 'values within 1.01e-3');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
At some point or another, most programmers find they need to compare
|
||||
floating-point numbers for equality. The typical idiom is to test
|
||||
if the absolute value of the difference of the numbers is within a desired
|
||||
tolerance, usually called epsilon. This module provides such a function for use
|
||||
with L<Test::More>. Usage is similar to other test functions described in
|
||||
L<Test::More>. Semantically, the C<delta_within> function replaces this kind
|
||||
of construct:
|
||||
|
||||
ok ( abs($p - $q) < $epsilon, '$p is equal to $q' ) or
|
||||
diag "$p is not equal to $q to within $epsilon";
|
||||
|
||||
While there's nothing wrong with that construct, it's painful to type it
|
||||
repeatedly in a test script. This module does the same thing with a single
|
||||
function call. The C<delta_ok> function is similar, but either uses a global
|
||||
default value for epsilon or else calculates a 'relative' epsilon on
|
||||
the fly so that epsilon is scaled automatically to the size of the arguments to
|
||||
C<delta_ok>. Both functions are exported automatically.
|
||||
|
||||
Because checking floating-point equality is not always reliable, it is not
|
||||
possible to check the 'equal to' boundary of 'less than or equal to
|
||||
epsilon'. Therefore, Test::Number::Delta only compares if the absolute value
|
||||
of the difference is B<less than> epsilon (for equality tests) or
|
||||
B<greater than> epsilon (for inequality tests).
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=head2 use Test::Number::Delta;
|
||||
|
||||
With no arguments, epsilon defaults to 1e-6. (An arbitrary choice on the
|
||||
author's part.)
|
||||
|
||||
=head2 use Test::Number::Delta within => 1e-9;
|
||||
|
||||
To specify a different default value for epsilon, provide a C<within> parameter
|
||||
when importing the module. The value must be non-zero.
|
||||
|
||||
=head2 use Test::Number::Delta relative => 1e-3;
|
||||
|
||||
As an alternative to using a fixed value for epsilon, provide a C<relative>
|
||||
parameter when importing the module. This signals that C<delta_ok> should
|
||||
test equality with an epsilon that is scaled to the size of the arguments.
|
||||
Epsilon is calculated as the relative value times the absolute value
|
||||
of the argument with the greatest magnitude. Mathematically, for arguments
|
||||
'x' and 'y':
|
||||
|
||||
epsilon = relative * max( abs(x), abs(y) )
|
||||
|
||||
For example, a relative value of "0.01" would mean that the arguments are equal
|
||||
if they differ by less than 1% of the larger of the two values. A relative
|
||||
value of 1e-6 means that the arguments must differ by less than 1 millionth
|
||||
of the larger value. The relative value must be non-zero.
|
||||
|
||||
=head2 Combining with a test plan
|
||||
|
||||
use Test::Number::Delta 'no_plan';
|
||||
|
||||
# or
|
||||
|
||||
use Test::Number::Delta within => 1e-9, tests => 1;
|
||||
|
||||
If a test plan has not already been specified, the optional
|
||||
parameter for Test::Number::Delta may be followed with a test plan (see
|
||||
L<Test::More> for details). If a parameter for Test::Number::Delta is
|
||||
given, it must come first.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 delta_within
|
||||
|
||||
delta_within( $p, $q, $epsilon, '$p and $q are equal within $epsilon' );
|
||||
delta_within( \@p, \@q, $epsilon, '@p and @q are equal within $epsilon' );
|
||||
|
||||
This function tests for equality within a given value of epsilon. The test is
|
||||
true if the absolute value of the difference between $p and $q is B<less than>
|
||||
epsilon. If the test is true, it prints an "OK" statement for use in testing.
|
||||
If the test is not true, this function prints a failure report and diagnostic.
|
||||
Epsilon must be non-zero.
|
||||
|
||||
The values to compare may be scalars or references to arrays. If the values
|
||||
are references to arrays, the comparison is done pairwise for each index value
|
||||
of the array. The pairwise comparison is recursive, so matrices may
|
||||
be compared as well.
|
||||
|
||||
For example, this code sample compares two matrices:
|
||||
|
||||
my @a = ( [ 3.14, 6.28 ],
|
||||
[ 1.41, 2.84 ] );
|
||||
|
||||
my @b = ( [ 3.14, 6.28 ],
|
||||
[ 1.42, 2.84 ] );
|
||||
|
||||
delta_within( \@a, \@b, 1e-6, 'compare @a and @b' );
|
||||
|
||||
The sample prints the following:
|
||||
|
||||
not ok 1 - compare @a and @b
|
||||
# At [1][0]: 1.4100000 and 1.4200000 are not equal to within 0.000001
|
||||
|
||||
=head2 delta_ok
|
||||
|
||||
delta_ok( $p, $q, '$p and $q are close enough to equal' );
|
||||
delta_ok( \@p, \@q, '@p and @q are close enough to equal' );
|
||||
|
||||
This function tests for equality within a default epsilon value. See L</USAGE>
|
||||
for details on changing the default. Otherwise, this function works the same
|
||||
as C<delta_within>.
|
||||
|
||||
=head2 delta_not_within
|
||||
|
||||
delta_not_within( $p, $q, '$p and $q are different' );
|
||||
delta_not_within( \@p, \@q, $epsilon, '@p and @q are different' );
|
||||
|
||||
This test compares inequality in excess of a given value of epsilon. The test
|
||||
is true if the absolute value of the difference between $p and $q is B<greater
|
||||
than> epsilon. For array or matrix comparisons, the test is true if I<any>
|
||||
pair of values differs by more than epsilon. Otherwise, this function works
|
||||
the same as C<delta_within>.
|
||||
|
||||
=head2 delta_not_ok
|
||||
|
||||
delta_not_ok( $p, $q, '$p and $q are different' );
|
||||
delta_not_ok( \@p, \@q, '@p and @q are different' );
|
||||
|
||||
This function tests for inequality in excess of a default epsilon value. See
|
||||
L</USAGE> for details on changing the default. Otherwise, this function works
|
||||
the same as C<delta_not_within>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
L<Number::Tolerant>
|
||||
|
||||
=item *
|
||||
|
||||
L<Test::Deep::NumberTolerant>
|
||||
|
||||
=back
|
||||
|
||||
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests through the issue tracker
|
||||
at L<https://github.com/dagolden/Test-Number-Delta/issues>.
|
||||
You will be notified automatically of any progress on your issue.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
This is open source software. The code repository is available for
|
||||
public review and contribution under the terms of the license.
|
||||
|
||||
L<https://github.com/dagolden/Test-Number-Delta>
|
||||
|
||||
git clone https://github.com/dagolden/Test-Number-Delta.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2014 by David Golden.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Apache License, Version 2.0, January 2004
|
||||
|
||||
=cut
|
||||
174
database/perl/vendor/lib/Test/Object.pm
vendored
Normal file
174
database/perl/vendor/lib/Test/Object.pm
vendored
Normal file
@@ -0,0 +1,174 @@
|
||||
package Test::Object; # git description: 1392ed9
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Object - Thoroughly testing objects via registered handlers
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.08
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
###################################################################
|
||||
# In your test module, register test handlers again class names #
|
||||
###################################################################
|
||||
|
||||
package My::ModuleTester;
|
||||
|
||||
use Test::More;
|
||||
use Test::Object;
|
||||
|
||||
# Foo::Bar is a subclass of Foo
|
||||
Test::Object->register(
|
||||
class => 'Foo',
|
||||
tests => 5,
|
||||
code => \&foo_ok,
|
||||
);
|
||||
Test::Object->register(
|
||||
class => 'Foo::Bar',
|
||||
# No fixed number of tests
|
||||
code => \&foobar_ok,
|
||||
);
|
||||
|
||||
sub foo_ok {
|
||||
my $object = shift;
|
||||
ok( $object->foo, '->foo returns true' );
|
||||
}
|
||||
|
||||
sub foobar_ok {
|
||||
my $object = shift;
|
||||
is( $object->foo, 'bar', '->foo returns "bar"' );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
|
||||
###################################################################
|
||||
# In test script, test object against all registered classes #
|
||||
###################################################################
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::More 'no_plan';
|
||||
use Test::Object;
|
||||
use My::ModuleTester;
|
||||
|
||||
my $object = Foo::Bar->new;
|
||||
isa_ok( $object, 'Foo::Bar' );
|
||||
object_ok( $object );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
In situations where you have deep trees of classes, there is a common
|
||||
situation in which you test a module 4 or 5 subclasses down, which should
|
||||
follow the correct behaviour of not just the subclass, but of all the
|
||||
parent classes.
|
||||
|
||||
This should be done to ensure that the implementation of a subclass has
|
||||
not somehow "broken" the object's behaviour in a more general sense.
|
||||
|
||||
C<Test::Object> is a testing package designed to allow you to easily test
|
||||
what you believe is a valid object against the expected behaviour of B<all>
|
||||
of the classes in its inheritance tree in one single call.
|
||||
|
||||
To do this, you "register" tests (in the form of CODE or function
|
||||
references) with C<Test::Object>, with each test associated with a
|
||||
particular class.
|
||||
|
||||
When you call C<object_ok> in your test script, C<Test::Object> will check
|
||||
the object against all registered tests. For each class that your object
|
||||
responds to C<$object-E<gt>isa($class)> for, the appropriate testing
|
||||
function will be called.
|
||||
|
||||
Doing it this way allows adapter objects and other things that respond
|
||||
to C<isa> differently that the default to still be tested against the
|
||||
classes that it is advertising itself as correctly.
|
||||
|
||||
This also means that more than one test might be "counted" for each call
|
||||
to C<object_ok>. You should account for this correctly in your expected
|
||||
test count.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Exporter ();
|
||||
use Test::More ();
|
||||
use Scalar::Util ();
|
||||
use Test::Object::Test ();
|
||||
|
||||
our $VERSION = '0.08';
|
||||
use vars qw{@ISA @EXPORT};
|
||||
BEGIN {
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT = 'object_ok';
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Registration and Planning
|
||||
|
||||
my @TESTS = ();
|
||||
|
||||
sub register {
|
||||
my $class = shift;
|
||||
push @TESTS, Test::Object::Test->new( @_ );
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Testing Functions
|
||||
|
||||
sub object_ok {
|
||||
my $object = Scalar::Util::blessed($_[0]) ? shift
|
||||
: Carp::croak("Did not provide an object to object_ok");
|
||||
|
||||
# Iterate over the tests and run any we ->isa
|
||||
foreach my $test ( @TESTS ) {
|
||||
$test->run( $object ) if $object->isa( $test->class );
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs should be submitted via the CPAN bug tracker, located at
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Object>
|
||||
|
||||
For other issues, contact the author.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://ali.as/>, L<Test::More>, L<Test::Builder::Tester>, L<Test::Class>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005, 2006 Adam Kennedy.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
74
database/perl/vendor/lib/Test/Object/Test.pm
vendored
Normal file
74
database/perl/vendor/lib/Test/Object/Test.pm
vendored
Normal file
@@ -0,0 +1,74 @@
|
||||
package Test::Object::Test;
|
||||
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Scalar::Util ();
|
||||
|
||||
our $VERSION = '0.08';
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Constructor and Accessors
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = bless { @_ }, $class;
|
||||
|
||||
# Check params
|
||||
unless ( _CLASS($self->class) ) {
|
||||
Carp::croak("Did not provide a valid test class");
|
||||
}
|
||||
unless ( _CODELIKE($self->code) ) {
|
||||
Carp::croak("Did not provide a valid CODE or callable object");
|
||||
}
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
sub class {
|
||||
$_[0]->{class};
|
||||
}
|
||||
|
||||
sub tests {
|
||||
$_[0]->{tests};
|
||||
}
|
||||
|
||||
sub code {
|
||||
$_[0]->{code};
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Main Methods
|
||||
|
||||
sub run {
|
||||
$_[0]->code->( $_[1] );
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Support Functions
|
||||
|
||||
# Stolen from Params::Util to avoid adding a dependency needlessly
|
||||
|
||||
sub _CLASS ($) {
|
||||
(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _CODELIKE {
|
||||
(Scalar::Util::reftype($_[0])||'') eq 'CODE'
|
||||
or
|
||||
Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}')
|
||||
? $_[0] : undef;
|
||||
}
|
||||
|
||||
1;
|
||||
932
database/perl/vendor/lib/Test/Output.pm
vendored
Normal file
932
database/perl/vendor/lib/Test/Output.pm
vendored
Normal file
@@ -0,0 +1,932 @@
|
||||
package Test::Output;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use Test::Builder;
|
||||
use Capture::Tiny qw/capture capture_stdout capture_stderr capture_merged/;
|
||||
|
||||
use Exporter qw(import);
|
||||
|
||||
our %EXPORT_TAGS = (
|
||||
stdout => [
|
||||
qw(
|
||||
stdout_is stdout_isnt stdout_like stdout_unlike
|
||||
)
|
||||
],
|
||||
stderr => [
|
||||
qw(
|
||||
stderr_is stderr_isnt stderr_like stderr_unlike
|
||||
)
|
||||
],
|
||||
output => [
|
||||
qw(
|
||||
output_is output_isnt output_like output_unlike
|
||||
)
|
||||
],
|
||||
combined => [
|
||||
qw(
|
||||
combined_is combined_isnt combined_like combined_unlike
|
||||
)
|
||||
],
|
||||
functions => [
|
||||
qw(
|
||||
output_from stderr_from stdout_from combined_from
|
||||
)
|
||||
],
|
||||
tests => [
|
||||
qw(
|
||||
output_is output_isnt output_like output_unlike
|
||||
stderr_is stderr_isnt stderr_like stderr_unlike
|
||||
stdout_is stdout_isnt stdout_like stdout_unlike
|
||||
combined_is combined_isnt combined_like combined_unlike
|
||||
)
|
||||
],
|
||||
all => [
|
||||
qw(
|
||||
output_is output_isnt output_like output_unlike
|
||||
stderr_is stderr_isnt stderr_like stderr_unlike
|
||||
stdout_is stdout_isnt stdout_like stdout_unlike
|
||||
combined_is combined_isnt combined_like combined_unlike
|
||||
output_from stderr_from stdout_from combined_from
|
||||
)
|
||||
],
|
||||
);
|
||||
|
||||
our @EXPORT = keys %{
|
||||
{
|
||||
map { $_ => 1 }
|
||||
map {
|
||||
@{ $EXPORT_TAGS{$_} }
|
||||
}
|
||||
keys %EXPORT_TAGS
|
||||
}
|
||||
};
|
||||
|
||||
my $Test = Test::Builder->new;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Output - Utilities to test STDOUT and STDERR messages.
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '1.031';
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::More tests => 4;
|
||||
use Test::Output;
|
||||
|
||||
sub writer {
|
||||
print "Write out.\n";
|
||||
print STDERR "Error out.\n";
|
||||
}
|
||||
|
||||
stdout_is(\&writer,"Write out.\n",'Test STDOUT');
|
||||
|
||||
stderr_isnt(\&writer,"No error out.\n",'Test STDERR');
|
||||
|
||||
combined_is(
|
||||
\&writer,
|
||||
"Write out.\nError out.\n",
|
||||
'Test STDOUT & STDERR combined'
|
||||
);
|
||||
|
||||
output_is(
|
||||
\&writer,
|
||||
"Write out.\n",
|
||||
"Error out.\n",
|
||||
'Test STDOUT & STDERR'
|
||||
);
|
||||
|
||||
# Use bare blocks.
|
||||
|
||||
stdout_is { print "test" } "test", "Test STDOUT";
|
||||
stderr_isnt { print "bad test" } "test", "Test STDERR";
|
||||
output_is { print 'STDOUT'; print STDERR 'STDERR' }
|
||||
"STDOUT", "STDERR", "Test output";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Test::Output provides a simple interface for testing output sent to C<STDOUT>
|
||||
or C<STDERR>. A number of different utilities are included to try and be as
|
||||
flexible as possible to the tester.
|
||||
|
||||
Likewise, L<Capture::Tiny> provides a much more robust capture mechanism without
|
||||
than the original L<Test::Output::Tie>.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 TESTS
|
||||
|
||||
=cut
|
||||
|
||||
=head2 STDOUT
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<stdout_is>
|
||||
|
||||
=item B<stdout_isnt>
|
||||
|
||||
stdout_is ( $coderef, $expected, 'description' );
|
||||
stdout_is { ... } $expected, 'description';
|
||||
stdout_isnt( $coderef, $expected, 'description' );
|
||||
stdout_isnt { ... } $expected, 'description';
|
||||
|
||||
C<stdout_is()> captures output sent to C<STDOUT> from C<$coderef> and compares
|
||||
it against C<$expected>. The test passes if equal.
|
||||
|
||||
C<stdout_isnt()> passes if C<STDOUT> is not equal to C<$expected>.
|
||||
|
||||
=cut
|
||||
|
||||
sub stdout_is (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my $stdout = stdout_from($test);
|
||||
|
||||
my $ok = ( $stdout eq $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDOUT is:\n$stdout\nnot:\n$expected\nas expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub stdout_isnt (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my $stdout = stdout_from($test);
|
||||
|
||||
my $ok = ( $stdout ne $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDOUT:\n$stdout\nmatching:\n$expected\nnot expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=item B<stdout_like>
|
||||
|
||||
=item B<stdout_unlike>
|
||||
|
||||
stdout_like ( $coderef, qr/$expected/, 'description' );
|
||||
stdout_like { ... } qr/$expected/, 'description';
|
||||
stdout_unlike( $coderef, qr/$expected/, 'description' );
|
||||
stdout_unlike { ... } qr/$expected/, 'description';
|
||||
|
||||
C<stdout_like()> captures the output sent to C<STDOUT> from C<$coderef> and compares
|
||||
it to the regex in C<$expected>. The test passes if the regex matches.
|
||||
|
||||
C<stdout_unlike()> passes if STDOUT does not match the regex.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub stdout_like (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
unless ( my $regextest = _chkregex( 'stdout_like' => $expected ) ) {
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $stdout = stdout_from($test);
|
||||
|
||||
my $ok = ( $stdout =~ $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDOUT:\n$stdout\ndoesn't match:\n$expected\nas expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub stdout_unlike (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
unless ( my $regextest = _chkregex( 'stdout_unlike' => $expected ) ) {
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $stdout = stdout_from($test);
|
||||
|
||||
my $ok = ( $stdout !~ $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDOUT:\n$stdout\nmatches:\n$expected\nnot expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=head2 STDERR
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<stderr_is>
|
||||
|
||||
=item B<stderr_isnt>
|
||||
|
||||
stderr_is ( $coderef, $expected, 'description' );
|
||||
stderr_is {... } $expected, 'description';
|
||||
|
||||
stderr_isnt( $coderef, $expected, 'description' );
|
||||
stderr_isnt {... } $expected, 'description';
|
||||
|
||||
C<stderr_is()> is similar to C<stdout_is>, except that it captures C<STDERR>. The
|
||||
test passes if C<STDERR> from C<$coderef> equals C<$expected>.
|
||||
|
||||
C<stderr_isnt()> passes if C<STDERR> is not equal to C<$expected>.
|
||||
|
||||
=cut
|
||||
|
||||
sub stderr_is (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my $stderr = stderr_from($test);
|
||||
|
||||
my $ok = ( $stderr eq $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDERR is:\n$stderr\nnot:\n$expected\nas expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub stderr_isnt (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my $stderr = stderr_from($test);
|
||||
|
||||
my $ok = ( $stderr ne $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDERR:\n$stderr\nmatches:\n$expected\nnot expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=item B<stderr_like>
|
||||
|
||||
=item B<stderr_unlike>
|
||||
|
||||
stderr_like ( $coderef, qr/$expected/, 'description' );
|
||||
stderr_like { ...} qr/$expected/, 'description';
|
||||
stderr_unlike( $coderef, qr/$expected/, 'description' );
|
||||
stderr_unlike { ...} qr/$expected/, 'description';
|
||||
|
||||
C<stderr_like()> is similar to C<stdout_like()> except that it compares the regex
|
||||
C<$expected> to C<STDERR> captured from C<$codref>. The test passes if the regex
|
||||
matches.
|
||||
|
||||
C<stderr_unlike()> passes if C<STDERR> does not match the regex.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub stderr_like (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
unless ( my $regextest = _chkregex( 'stderr_like' => $expected ) ) {
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $stderr = stderr_from($test);
|
||||
|
||||
my $ok = ( $stderr =~ $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDERR:\n$stderr\ndoesn't match:\n$expected\nas expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub stderr_unlike (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
unless ( my $regextest = _chkregex( 'stderr_unlike' => $expected ) ) {
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $stderr = stderr_from($test);
|
||||
|
||||
my $ok = ( $stderr !~ $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag("STDERR:\n$stderr\nmatches:\n$expected\nnot expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=head2 COMBINED OUTPUT
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<combined_is>
|
||||
|
||||
=item B<combined_isnt>
|
||||
|
||||
combined_is ( $coderef, $expected, 'description' );
|
||||
combined_is {... } $expected, 'description';
|
||||
combined_isnt ( $coderef, $expected, 'description' );
|
||||
combined_isnt {... } $expected, 'description';
|
||||
|
||||
C<combined_is()> directs C<STDERR> to C<STDOUT> then captures C<STDOUT>. This is
|
||||
equivalent to UNIXs C<< 2>&1 >>. The test passes if the combined C<STDOUT>
|
||||
and C<STDERR> from $coderef equals $expected.
|
||||
|
||||
C<combined_isnt()> passes if combined C<STDOUT> and C<STDERR> are not equal
|
||||
to C<$expected>.
|
||||
|
||||
=cut
|
||||
|
||||
sub combined_is (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my $combined = combined_from($test);
|
||||
|
||||
my $ok = ( $combined eq $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag(
|
||||
"STDOUT & STDERR are:\n$combined\nnot:\n$expected\nas expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub combined_isnt (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my $combined = combined_from($test);
|
||||
|
||||
my $ok = ( $combined ne $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag(
|
||||
"STDOUT & STDERR:\n$combined\nmatching:\n$expected\nnot expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=item B<combined_like>
|
||||
|
||||
=item B<combined_unlike>
|
||||
|
||||
combined_like ( $coderef, qr/$expected/, 'description' );
|
||||
combined_like { ...} qr/$expected/, 'description';
|
||||
combined_unlike ( $coderef, qr/$expected/, 'description' );
|
||||
combined_unlike { ...} qr/$expected/, 'description';
|
||||
|
||||
C<combined_like()> is similar to C<combined_is()> except that it compares a regex
|
||||
(C<$expected)> to C<STDOUT> and C<STDERR> captured from C<$codref>. The test passes if
|
||||
the regex matches.
|
||||
|
||||
C<combined_unlike()> passes if the combined C<STDOUT> and C<STDERR> does not match
|
||||
the regex.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub combined_like (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
unless ( my $regextest = _chkregex( 'combined_like' => $expected ) ) {
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $combined = combined_from($test);
|
||||
|
||||
my $ok = ( $combined =~ $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag(
|
||||
"STDOUT & STDERR:\n$combined\ndon't match:\n$expected\nas expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub combined_unlike (&$;$$) {
|
||||
my $test = shift;
|
||||
my $expected = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
unless ( my $regextest = _chkregex( 'combined_unlike' => $expected ) ) {
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $combined = combined_from($test);
|
||||
|
||||
my $ok = ( $combined !~ $expected );
|
||||
|
||||
$Test->ok( $ok, $description )
|
||||
|| $Test->diag(
|
||||
"STDOUT & STDERR:\n$combined\nmatching:\n$expected\nnot expected");
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=head2 OUTPUT
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<output_is>
|
||||
|
||||
=item B<output_isnt>
|
||||
|
||||
output_is ( $coderef, $expected_stdout, $expected_stderr, 'description' );
|
||||
output_is {... } $expected_stdout, $expected_stderr, 'description';
|
||||
output_isnt( $coderef, $expected_stdout, $expected_stderr, 'description' );
|
||||
output_isnt {... } $expected_stdout, $expected_stderr, 'description';
|
||||
|
||||
The C<output_is()> function is a combination of the C<stdout_is()> and C<stderr_is()>
|
||||
functions. For example:
|
||||
|
||||
output_is(sub {print "foo"; print STDERR "bar";},'foo','bar');
|
||||
|
||||
is functionally equivalent to
|
||||
|
||||
stdout_is(sub {print "foo";},'foo')
|
||||
&& stderr_is(sub {print STDERR "bar";'bar');
|
||||
|
||||
except that C<$coderef> is only executed once.
|
||||
|
||||
Unlike C<stdout_is()> and C<stderr_is()> which ignore STDERR and STDOUT
|
||||
respectively, C<output_is()> requires both C<STDOUT> and C<STDERR> to match in order
|
||||
to pass. Setting either C<$expected_stdout> or C<$expected_stderr> to C<undef>
|
||||
ignores C<STDOUT> or C<STDERR> respectively.
|
||||
|
||||
output_is(sub {print "foo"; print STDERR "bar";},'foo',undef);
|
||||
|
||||
is the same as
|
||||
|
||||
stdout_is(sub {print "foo";},'foo')
|
||||
|
||||
C<output_isnt()> provides the opposite function of C<output_is()>. It is a
|
||||
combination of C<stdout_isnt()> and C<stderr_isnt()>.
|
||||
|
||||
output_isnt(sub {print "foo"; print STDERR "bar";},'bar','foo');
|
||||
|
||||
is functionally equivalent to
|
||||
|
||||
stdout_is(sub {print "foo";},'bar')
|
||||
&& stderr_is(sub {print STDERR "bar";'foo');
|
||||
|
||||
As with C<output_is()>, setting either C<$expected_stdout> or C<$expected_stderr> to
|
||||
C<undef> ignores the output to that facility.
|
||||
|
||||
output_isnt(sub {print "foo"; print STDERR "bar";},undef,'foo');
|
||||
|
||||
is the same as
|
||||
|
||||
stderr_is(sub {print STDERR "bar";},'foo')
|
||||
|
||||
=cut
|
||||
|
||||
sub output_is (&$$;$$) {
|
||||
my $test = shift;
|
||||
my $expout = shift;
|
||||
my $experr = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my ( $stdout, $stderr ) = output_from($test);
|
||||
|
||||
my $ok = 1;
|
||||
my $diag;
|
||||
|
||||
if ( defined($experr) && defined($expout) ) {
|
||||
unless ( $stdout eq $expout ) {
|
||||
$ok = 0;
|
||||
$diag .= "STDOUT is:\n$stdout\nnot:\n$expout\nas expected";
|
||||
}
|
||||
unless ( $stderr eq $experr ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR is:\n$stderr\nnot:\n$experr\nas expected";
|
||||
}
|
||||
}
|
||||
elsif ( defined($expout) ) {
|
||||
$ok = ( $stdout eq $expout );
|
||||
$diag .= "STDOUT is:\n$stdout\nnot:\n$expout\nas expected";
|
||||
}
|
||||
elsif ( defined($experr) ) {
|
||||
$ok = ( $stderr eq $experr );
|
||||
$diag .= "STDERR is:\n$stderr\nnot:\n$experr\nas expected";
|
||||
}
|
||||
else {
|
||||
unless ( $stdout eq '' ) {
|
||||
$ok = 0;
|
||||
$diag .= "STDOUT is:\n$stdout\nnot:\n\nas expected";
|
||||
}
|
||||
unless ( $stderr eq '' ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR is:\n$stderr\nnot:\n\nas expected";
|
||||
}
|
||||
}
|
||||
|
||||
$Test->ok( $ok, $description ) || $Test->diag($diag);
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub output_isnt (&$$;$$) {
|
||||
my $test = shift;
|
||||
my $expout = shift;
|
||||
my $experr = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my ( $stdout, $stderr ) = output_from($test);
|
||||
|
||||
my $ok = 1;
|
||||
my $diag;
|
||||
|
||||
if ( defined($experr) && defined($expout) ) {
|
||||
if ( $stdout eq $expout ) {
|
||||
$ok = 0;
|
||||
$diag .= "STDOUT:\n$stdout\nmatching:\n$expout\nnot expected";
|
||||
}
|
||||
if ( $stderr eq $experr ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR:\n$stderr\nmatching:\n$experr\nnot expected";
|
||||
}
|
||||
}
|
||||
elsif ( defined($expout) ) {
|
||||
$ok = ( $stdout ne $expout );
|
||||
$diag = "STDOUT:\n$stdout\nmatching:\n$expout\nnot expected";
|
||||
}
|
||||
elsif ( defined($experr) ) {
|
||||
$ok = ( $stderr ne $experr );
|
||||
$diag = "STDERR:\n$stderr\nmatching:\n$experr\nnot expected";
|
||||
}
|
||||
else {
|
||||
if ( $stdout eq '' ) {
|
||||
$ok = 0;
|
||||
$diag = "STDOUT:\n$stdout\nmatching:\n\nnot expected";
|
||||
}
|
||||
if ( $stderr eq '' ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR:\n$stderr\nmatching:\n\nnot expected";
|
||||
}
|
||||
}
|
||||
|
||||
$Test->ok( $ok, $description ) || $Test->diag($diag);
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=item B<output_like>
|
||||
|
||||
=item B<output_unlike>
|
||||
|
||||
output_like ( $coderef, $regex_stdout, $regex_stderr, 'description' );
|
||||
output_like { ... } $regex_stdout, $regex_stderr, 'description';
|
||||
output_unlike( $coderef, $regex_stdout, $regex_stderr, 'description' );
|
||||
output_unlike { ... } $regex_stdout, $regex_stderr, 'description';
|
||||
|
||||
C<output_like()> and C<output_unlike()> follow the same principles as C<output_is()>
|
||||
and C<output_isnt()> except they use a regular expression for matching.
|
||||
|
||||
C<output_like()> attempts to match C<$regex_stdout> and C<$regex_stderr> against
|
||||
C<STDOUT> and C<STDERR> produced by $coderef. The test passes if both match.
|
||||
|
||||
output_like(sub {print "foo"; print STDERR "bar";},qr/foo/,qr/bar/);
|
||||
|
||||
The above test is successful.
|
||||
|
||||
Like C<output_is()>, setting either C<$regex_stdout> or C<$regex_stderr> to
|
||||
C<undef> ignores the output to that facility.
|
||||
|
||||
output_like(sub {print "foo"; print STDERR "bar";},qr/foo/,undef);
|
||||
|
||||
is the same as
|
||||
|
||||
stdout_like(sub {print "foo"; print STDERR "bar";},qr/foo/);
|
||||
|
||||
C<output_unlike()> test pass if output from C<$coderef> doesn't match
|
||||
C<$regex_stdout> and C<$regex_stderr>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub output_like (&$$;$$) {
|
||||
my $test = shift;
|
||||
my $expout = shift;
|
||||
my $experr = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my ( $stdout, $stderr ) = output_from($test);
|
||||
|
||||
my $ok = 1;
|
||||
|
||||
unless (
|
||||
my $regextest = _chkregex(
|
||||
'output_like_STDERR' => $experr,
|
||||
'output_like_STDOUT' => $expout
|
||||
)
|
||||
)
|
||||
{
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $diag;
|
||||
if ( defined($experr) && defined($expout) ) {
|
||||
unless ( $stdout =~ $expout ) {
|
||||
$ok = 0;
|
||||
$diag .= "STDOUT:\n$stdout\ndoesn't match:\n$expout\nas expected";
|
||||
}
|
||||
unless ( $stderr =~ $experr ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR:\n$stderr\ndoesn't match:\n$experr\nas expected";
|
||||
}
|
||||
}
|
||||
elsif ( defined($expout) ) {
|
||||
$ok = ( $stdout =~ $expout );
|
||||
$diag .= "STDOUT:\n$stdout\ndoesn't match:\n$expout\nas expected";
|
||||
}
|
||||
elsif ( defined($experr) ) {
|
||||
$ok = ( $stderr =~ $experr );
|
||||
$diag .= "STDERR:\n$stderr\ndoesn't match:\n$experr\nas expected";
|
||||
}
|
||||
else {
|
||||
unless ( $stdout eq '' ) {
|
||||
$ok = 0;
|
||||
$diag .= "STDOUT is:\n$stdout\nnot:\n\nas expected";
|
||||
}
|
||||
unless ( $stderr eq '' ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR is:\n$stderr\nnot:\n\nas expected";
|
||||
}
|
||||
}
|
||||
|
||||
$Test->ok( $ok, $description ) || $Test->diag($diag);
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub output_unlike (&$$;$$) {
|
||||
my $test = shift;
|
||||
my $expout = shift;
|
||||
my $experr = shift;
|
||||
my $options = shift if ( ref( $_[0] ) );
|
||||
my $description = shift;
|
||||
|
||||
my ( $stdout, $stderr ) = output_from($test);
|
||||
|
||||
my $ok = 1;
|
||||
|
||||
unless (
|
||||
my $regextest = _chkregex(
|
||||
'output_unlike_STDERR' => $experr,
|
||||
'output_unlike_STDOUT' => $expout
|
||||
)
|
||||
)
|
||||
{
|
||||
return $regextest;
|
||||
}
|
||||
|
||||
my $diag;
|
||||
if ( defined($experr) && defined($expout) ) {
|
||||
if ( $stdout =~ $expout ) {
|
||||
$ok = 0;
|
||||
$diag .= "STDOUT:\n$stdout\nmatches:\n$expout\nnot expected";
|
||||
}
|
||||
if ( $stderr =~ $experr ) {
|
||||
$diag .= "\n" unless ($ok);
|
||||
$ok = 0;
|
||||
$diag .= "STDERR:\n$stderr\nmatches:\n$experr\nnot expected";
|
||||
}
|
||||
}
|
||||
elsif ( defined($expout) ) {
|
||||
$ok = ( $stdout !~ $expout );
|
||||
$diag .= "STDOUT:\n$stdout\nmatches:\n$expout\nnot expected";
|
||||
}
|
||||
elsif ( defined($experr) ) {
|
||||
$ok = ( $stderr !~ $experr );
|
||||
$diag .= "STDERR:\n$stderr\nmatches:\n$experr\nnot expected";
|
||||
}
|
||||
|
||||
$Test->ok( $ok, $description ) || $Test->diag($diag);
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
By default, all subroutines are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * :stdout - the subs with C<stdout> in the name.
|
||||
|
||||
=item * :stderr - the subs with C<stderr> in the name.
|
||||
|
||||
=item * :functions - the subs with C<_from> at the end.
|
||||
|
||||
=item * :output - the subs with C<output> in the name.
|
||||
|
||||
=item * :combined - the subs with C<combined> in the name.
|
||||
|
||||
=item * :tests - everything that outputs TAP
|
||||
|
||||
=item * :all - everything (which is the same as the default)
|
||||
|
||||
=back
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
=head2 stdout_from
|
||||
|
||||
my $stdout = stdout_from($coderef)
|
||||
my $stdout = stdout_from { ... };
|
||||
|
||||
stdout_from() executes $coderef and captures STDOUT.
|
||||
|
||||
=cut
|
||||
|
||||
sub stdout_from (&) {
|
||||
my $test = shift;
|
||||
|
||||
my $stdout = capture_stdout {
|
||||
select( ( select(STDOUT), $| = 1 )[0] );
|
||||
$test->()
|
||||
};
|
||||
|
||||
return $stdout;
|
||||
}
|
||||
|
||||
=head2 stderr_from
|
||||
|
||||
my $stderr = stderr_from($coderef)
|
||||
my $stderr = stderr_from { ... };
|
||||
|
||||
C<stderr_from()> executes C<$coderef> and captures C<STDERR>.
|
||||
|
||||
=cut
|
||||
|
||||
sub stderr_from (&) {
|
||||
my $test = shift;
|
||||
|
||||
# XXX why is this here and not in output_from or combined_from -- xdg, 2012-05-13
|
||||
local $SIG{__WARN__} = sub { print STDERR @_ }
|
||||
if $] < 5.008;
|
||||
|
||||
my $stderr = capture_stderr {
|
||||
select( ( select(STDERR), $| = 1 )[0] );
|
||||
$test->()
|
||||
};
|
||||
|
||||
return $stderr;
|
||||
}
|
||||
|
||||
=head2 output_from
|
||||
|
||||
my ($stdout, $stderr) = output_from($coderef)
|
||||
my ($stdout, $stderr) = output_from {...};
|
||||
|
||||
C<output_from()> executes C<$coderef> one time capturing both C<STDOUT> and C<STDERR>.
|
||||
|
||||
=cut
|
||||
|
||||
sub output_from (&) {
|
||||
my $test = shift;
|
||||
|
||||
my ($stdout, $stderr) = capture {
|
||||
select( ( select(STDOUT), $| = 1 )[0] );
|
||||
select( ( select(STDERR), $| = 1 )[0] );
|
||||
$test->();
|
||||
};
|
||||
|
||||
return ( $stdout, $stderr );
|
||||
}
|
||||
|
||||
=head2 combined_from
|
||||
|
||||
my $combined = combined_from($coderef);
|
||||
my $combined = combined_from {...};
|
||||
|
||||
C<combined_from()> executes C<$coderef> one time combines C<STDOUT> and C<STDERR>, and
|
||||
captures them. C<combined_from()> is equivalent to using C<< 2>&1 >> in UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub combined_from (&) {
|
||||
my $test = shift;
|
||||
|
||||
my $combined = capture_merged {
|
||||
select( ( select(STDOUT), $| = 1 )[0] );
|
||||
select( ( select(STDERR), $| = 1 )[0] );
|
||||
$test->();
|
||||
};
|
||||
|
||||
return $combined;
|
||||
}
|
||||
|
||||
sub _chkregex {
|
||||
my %regexs = @_;
|
||||
|
||||
foreach my $test ( keys(%regexs) ) {
|
||||
next unless ( defined( $regexs{$test} ) );
|
||||
|
||||
my $usable_regex = $Test->maybe_regex( $regexs{$test} );
|
||||
unless ( defined($usable_regex) ) {
|
||||
my $ok = $Test->ok( 0, $test );
|
||||
|
||||
$Test->diag("'$regexs{$test}' doesn't look much like a regex to me.");
|
||||
# unless $ok;
|
||||
|
||||
return $ok;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Currently maintained by brian d foy, C<bdfoy@cpan.org>.
|
||||
|
||||
Shawn Sorichetti, C<< <ssoriche@cpan.org> >>
|
||||
|
||||
=head1 SOURCE AVAILABILITY
|
||||
|
||||
This module is in Github:
|
||||
|
||||
http://github.com/briandfoy/test-output/tree/master
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to
|
||||
C<bug-test-output@rt.cpan.org>, or through the web interface at
|
||||
L<http://rt.cpan.org>. I will be notified, and then you'll automatically
|
||||
be notified of progress on your bug as I make changes.
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
Thanks to chromatic whose TieOut.pm was the basis for capturing output.
|
||||
|
||||
Also thanks to rjbs for his help cleaning the documentation, and pushing me to
|
||||
L<Sub::Exporter>. (This feature has been removed since it uses none of
|
||||
L<Sub::Exporter>'s strengths).
|
||||
|
||||
Thanks to David Wheeler for providing code block support and tests.
|
||||
|
||||
Thanks to Michael G Schwern for the solution to combining C<STDOUT> and C<STDERR>.
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright 2005-2013 Shawn Sorichetti, All Rights Reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1; # End of Test::Output
|
||||
147
database/perl/vendor/lib/Test/Requires.pm
vendored
Normal file
147
database/perl/vendor/lib/Test/Requires.pm
vendored
Normal file
@@ -0,0 +1,147 @@
|
||||
package Test::Requires;
|
||||
use strict;
|
||||
use warnings;
|
||||
our $VERSION = '0.11';
|
||||
use base 'Test::Builder::Module';
|
||||
use 5.006;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my $caller = caller(0);
|
||||
|
||||
# export methods
|
||||
{
|
||||
no strict 'refs';
|
||||
*{"$caller\::test_requires"} = \&test_requires;
|
||||
}
|
||||
|
||||
# test arguments
|
||||
if (@_ == 1 && ref $_[0] && ref $_[0] eq 'HASH') {
|
||||
while (my ($mod, $ver) = each %{$_[0]}) {
|
||||
test_requires($mod, $ver, $caller);
|
||||
}
|
||||
} else {
|
||||
for my $mod (@_) {
|
||||
test_requires($mod, undef, $caller);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub test_requires {
|
||||
my ( $mod, $ver, $caller ) = @_;
|
||||
return if $mod eq __PACKAGE__;
|
||||
if (@_ != 3) {
|
||||
$caller = caller(0);
|
||||
}
|
||||
$ver ||= '';
|
||||
|
||||
eval qq{package $caller; use $mod $ver}; ## no critic.
|
||||
if (my $e = $@) {
|
||||
my $skip_all = sub {
|
||||
my $builder = __PACKAGE__->builder;
|
||||
|
||||
if (not defined $builder->has_plan) {
|
||||
$builder->skip_all(@_);
|
||||
} elsif ($builder->has_plan eq 'no_plan') {
|
||||
$builder->skip(@_);
|
||||
if ( $builder->can('parent') && $builder->parent ) {
|
||||
die bless {} => 'Test::Builder::Exception';
|
||||
}
|
||||
exit 0;
|
||||
} else {
|
||||
for (1..$builder->has_plan) {
|
||||
$builder->skip(@_);
|
||||
}
|
||||
if ( $builder->can('parent') && $builder->parent ) {
|
||||
die bless {} => 'Test::Builder::Exception';
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
};
|
||||
|
||||
my $msg = "$e";
|
||||
if ( $e =~ /^Can't locate/ ) {
|
||||
$msg = "Test requires module '$mod' but it's not found";
|
||||
}
|
||||
|
||||
if ($ENV{RELEASE_TESTING}) {
|
||||
__PACKAGE__->builder->BAIL_OUT($msg);
|
||||
}
|
||||
else {
|
||||
$skip_all->($msg);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Requires - Checks to see if the module can be loaded
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# in your Makefile.PL
|
||||
use inc::Module::Install;
|
||||
test_requires 'Test::Requires';
|
||||
|
||||
# in your test
|
||||
use Test::More tests => 10;
|
||||
use Test::Requires {
|
||||
'HTTP::MobileAttribute' => 0.01, # skip all if HTTP::MobileAttribute doesn't installed
|
||||
};
|
||||
isa_ok HTTP::MobileAttribute->new, 'HTTP::MobileAttribute::NonMobile';
|
||||
|
||||
# or
|
||||
use Test::More tests => 10;
|
||||
use Test::Requires qw(
|
||||
HTTP::MobileAttribute
|
||||
);
|
||||
isa_ok HTTP::MobileAttribute->new, 'HTTP::MobileAttribute::NonMobile';
|
||||
|
||||
# or
|
||||
use Test::More tests => 10;
|
||||
use Test::Requires;
|
||||
test_requires 'Some::Optional::Test::Required::Modules';
|
||||
isa_ok HTTP::MobileAttribute->new, 'HTTP::MobileAttribute::NonMobile';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Test::Requires checks to see if the module can be loaded.
|
||||
|
||||
If this fails rather than failing tests this B<skips all tests>.
|
||||
|
||||
Test::Requires can also be used to require a minimum version of Perl:
|
||||
|
||||
use Test::Requires "5.010"; # quoting is necessary!!
|
||||
|
||||
# or
|
||||
use Test::Requires "v5.10";
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tokuhiro Matsuno E<lt>tokuhirom @*(#RJKLFHFSDLJF gmail.comE<gt>
|
||||
|
||||
=head1 THANKS TO
|
||||
|
||||
kazuho++ # some tricky stuff
|
||||
miyagawa++ # original code from t/TestPlagger.pm
|
||||
tomyhero++ # reported issue related older test::builder
|
||||
tobyink++ # documented that Test::Requires "5.010" works
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
If the C<< RELEASE_TESTING >> environment variable is true, then instead
|
||||
of skipping tests, Test::Requires bails out.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<t/TestPlagger.pm>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
131
database/perl/vendor/lib/Test/RequiresInternet.pm
vendored
Normal file
131
database/perl/vendor/lib/Test/RequiresInternet.pm
vendored
Normal file
@@ -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
|
||||
793
database/perl/vendor/lib/Test/Script.pm
vendored
Normal file
793
database/perl/vendor/lib/Test/Script.pm
vendored
Normal file
@@ -0,0 +1,793 @@
|
||||
package Test::Script;
|
||||
|
||||
# ABSTRACT: Basic cross-platform tests for scripts
|
||||
our $VERSION = '1.26'; # VERSION
|
||||
|
||||
|
||||
use 5.008001;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( croak );
|
||||
use Exporter;
|
||||
use File::Spec;
|
||||
use File::Spec::Unix;
|
||||
use Probe::Perl;
|
||||
use Capture::Tiny qw( capture );
|
||||
use Test2::API qw( context );
|
||||
use File::Temp qw( tempdir );
|
||||
use IO::Handle;
|
||||
|
||||
our @ISA = 'Exporter';
|
||||
our @EXPORT = qw{
|
||||
script_compiles
|
||||
script_compiles_ok
|
||||
script_runs
|
||||
script_stdout_is
|
||||
script_stdout_isnt
|
||||
script_stdout_like
|
||||
script_stdout_unlike
|
||||
script_stderr_is
|
||||
script_stderr_isnt
|
||||
script_stderr_like
|
||||
script_stderr_unlike
|
||||
program_runs
|
||||
program_stdout_is
|
||||
program_stdout_isnt
|
||||
program_stdout_like
|
||||
program_stdout_unlike
|
||||
program_stderr_is
|
||||
program_stderr_isnt
|
||||
program_stderr_like
|
||||
program_stderr_unlike
|
||||
};
|
||||
|
||||
sub import {
|
||||
my $self = shift;
|
||||
my $pack = caller;
|
||||
if(defined $_[0] && $_[0] =~ /^(?:no_plan|skip_all|tests)$/)
|
||||
{
|
||||
# icky back compat.
|
||||
# do not use.
|
||||
my $ctx = context();
|
||||
if($_[0] eq 'tests')
|
||||
{
|
||||
$ctx->plan($_[1]);
|
||||
}
|
||||
elsif($_[0] eq 'skip_all')
|
||||
{
|
||||
$ctx->plan(0, 'SKIP', $_[1]);
|
||||
}
|
||||
else
|
||||
{
|
||||
$ctx->hub->plan('NO PLAN');
|
||||
}
|
||||
$ctx->release;
|
||||
}
|
||||
foreach ( @EXPORT ) {
|
||||
$self->export_to_level(1, $self, $_);
|
||||
}
|
||||
}
|
||||
|
||||
my $perl = undef;
|
||||
|
||||
sub perl () {
|
||||
$perl or
|
||||
$perl = Probe::Perl->find_perl_interpreter;
|
||||
}
|
||||
|
||||
sub path ($) {
|
||||
my $path = shift;
|
||||
unless ( defined $path ) {
|
||||
croak("Did not provide a script name");
|
||||
}
|
||||
if ( File::Spec::Unix->file_name_is_absolute($path) ) {
|
||||
croak("Script name must be relative");
|
||||
}
|
||||
File::Spec->catfile(
|
||||
File::Spec->curdir,
|
||||
split /\//, $path
|
||||
);
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Test Functions for Scripts
|
||||
|
||||
|
||||
sub script_compiles {
|
||||
my $args = _script(shift);
|
||||
my $unix = shift @$args;
|
||||
my $path = path( $unix );
|
||||
my $pargs = _perl_args($path);
|
||||
my $dir = _preload_module();
|
||||
my $cmd = [ perl, @$pargs, "-I$dir", '-M__TEST_SCRIPT__', '-c', $path, @$args ];
|
||||
my ($stdout, $stderr) = capture { system(@$cmd) };
|
||||
my $error = $@;
|
||||
my $exit = $? ? ($? >> 8) : 0;
|
||||
my $signal = $? ? ($? & 127) : 0;
|
||||
my $ok = !! (
|
||||
$error eq '' and $exit == 0 and $signal == 0 and $stderr =~ /syntax OK\s+\z/si
|
||||
);
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok( $ok, $_[0] || "Script $unix compiles" );
|
||||
$ctx->diag( "$exit - $stderr" ) unless $ok;
|
||||
$ctx->diag( "exception: $error" ) if $error;
|
||||
$ctx->diag( "signal: $signal" ) if $signal;
|
||||
$ctx->release;
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
# this is noticeably slower for long @INC lists (sometimes present in cpantesters
|
||||
# boxes) than the previous implementation, which added a -I for every element in
|
||||
# @INC. (also slower for more reasonable @INCs, but not noticeably). But it is
|
||||
# safer as very long argument lists can break calls to system
|
||||
sub _preload_module
|
||||
{
|
||||
my @opts = ( '.test-script-XXXXXXXX', CLEANUP => 1);
|
||||
if(-w File::Spec->curdir)
|
||||
{ push @opts, DIR => File::Spec->curdir }
|
||||
else
|
||||
{ push @opts, DIR => File::Spec->tmpdir }
|
||||
my $dir = tempdir(@opts);
|
||||
$dir = File::Spec->rel2abs($dir);
|
||||
# this is hopefully a pm file that nobody would use
|
||||
my $filename = File::Spec->catfile($dir, '__TEST_SCRIPT__.pm');
|
||||
my $fh;
|
||||
open($fh, '>', $filename)
|
||||
|| die "unable to open $filename: $!";
|
||||
print($fh 'unshift @INC, ',
|
||||
join ',',
|
||||
# quotemeta is overkill, but it will make sure that characters
|
||||
# like " are quoted
|
||||
map { '"' . quotemeta($_) . '"' }
|
||||
grep { ! ref } @INC)
|
||||
|| die "unable to write $filename: $!";
|
||||
close($fh) || die "unable to close $filename: $!";;
|
||||
$dir;
|
||||
}
|
||||
|
||||
|
||||
my $stdout;
|
||||
my $stderr;
|
||||
|
||||
sub script_runs {
|
||||
my $args = _script(shift);
|
||||
my $opt = _options(\$stdout, \$stderr, 1, \@_);
|
||||
my $unix = shift @$args;
|
||||
my $path = path( $unix );
|
||||
my $pargs = [ @{ _perl_args($path) }, @{ $opt->{interpreter_options} } ];
|
||||
my $dir = _preload_module();
|
||||
my $cmd = [ perl, @$pargs, "-I$dir", '-M__TEST_SCRIPT__', $path, @$args ];
|
||||
$stdout = '';
|
||||
$stderr = '';
|
||||
|
||||
unshift @_, "Script $unix runs" unless $_[0];
|
||||
unshift @_, $cmd, $opt;
|
||||
goto &_run;
|
||||
}
|
||||
|
||||
# Run a script or program and provide test events corresponding to the results.
|
||||
# Call as _run(\@cmd, \%opt, "Test description")
|
||||
sub _run {
|
||||
my ($cmd, $opt, $description) = @_;
|
||||
|
||||
if($opt->{stdin})
|
||||
{
|
||||
my $filename;
|
||||
|
||||
if(ref($opt->{stdin}) eq 'SCALAR')
|
||||
{
|
||||
$filename = File::Spec->catfile(
|
||||
tempdir(CLEANUP => 1),
|
||||
'stdin.txt',
|
||||
);
|
||||
my $tmp;
|
||||
open($tmp, '>', $filename) || die "unable to write to $filename";
|
||||
print $tmp ${ $opt->{stdin} };
|
||||
close $tmp;
|
||||
}
|
||||
elsif(ref($opt->{stdin}) eq '')
|
||||
{
|
||||
$filename = $opt->{stdin};
|
||||
}
|
||||
else
|
||||
{
|
||||
croak("stdin MUST be either a scalar reference or a string filename");
|
||||
}
|
||||
|
||||
my $fh;
|
||||
open($fh, '<', $filename) || die "unable to open $filename $!";
|
||||
STDIN->fdopen( $fh, 'r' ) or die "unable to reopen stdin to $filename $!";
|
||||
}
|
||||
|
||||
(${$opt->{stdout}}, ${$opt->{stderr}}) = capture { system(@$cmd) };
|
||||
|
||||
my $error = $@;
|
||||
my $exit = $? ? ($? >> 8) : 0;
|
||||
my $signal = $? ? ($? & 127) : 0;
|
||||
my $ok = !! ( $error eq '' and $exit == $opt->{exit} and $signal == $opt->{signal} );
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->ok( $ok, $description );
|
||||
$ctx->diag( "$exit - " . ${$opt->{stderr}} ) unless $ok;
|
||||
$ctx->diag( "exception: $error" ) if $error;
|
||||
$ctx->diag( "signal: $signal" ) unless $signal == $opt->{signal};
|
||||
$ctx->release;
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub _like
|
||||
{
|
||||
my($text, $pattern, $regex, $not, $name) = @_;
|
||||
|
||||
my $ok = $regex ? $text =~ $pattern : $text eq $pattern;
|
||||
$ok = !$ok if $not;
|
||||
|
||||
my $ctx = context;
|
||||
$ctx->ok( $ok, $name );
|
||||
unless($ok) {
|
||||
$ctx->diag( "The output" );
|
||||
$ctx->diag( " $_") for split /\n/, $text;
|
||||
$ctx->diag( $not ? "does match" : "does not match" );
|
||||
if($regex) {
|
||||
$ctx->diag( " $pattern" );
|
||||
} else {
|
||||
$ctx->diag( " $_" ) for split /\n/, $pattern;
|
||||
}
|
||||
}
|
||||
$ctx->release;
|
||||
|
||||
$ok;
|
||||
}
|
||||
|
||||
|
||||
sub script_stdout_is
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stdout, $pattern, 0, 0, $name || 'stdout matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stdout_isnt
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stdout, $pattern, 0, 1, $name || 'stdout does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stdout_like
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stdout, $pattern, 1, 0, $name || 'stdout matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stdout_unlike
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stdout, $pattern, 1, 1, $name || 'stdout does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stderr_is
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stderr, $pattern, 0, 0, $name || 'stderr matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stderr_isnt
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stderr, $pattern, 0, 1, $name || 'stderr does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stderr_like
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stderr, $pattern, 1, 0, $name || 'stderr matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub script_stderr_unlike
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($stderr, $pattern, 1, 1, $name || 'stderr does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Test Functions for Programs
|
||||
|
||||
my $program_stdout;
|
||||
my $program_stderr;
|
||||
|
||||
|
||||
sub program_runs {
|
||||
my $cmd = _script(shift);
|
||||
my $opt = _options(\$program_stdout, \$program_stderr, 0, \@_);
|
||||
$program_stdout = '';
|
||||
$program_stderr = '';
|
||||
|
||||
unshift @_, "Program $$cmd[0] runs" unless $_[0];
|
||||
unshift @_, $cmd, $opt;
|
||||
goto &_run;
|
||||
}
|
||||
|
||||
|
||||
sub program_stdout_is
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stdout, $pattern, 0, 0, $name || 'stdout matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stdout_isnt
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stdout, $pattern, 0, 1, $name || 'stdout does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stdout_like
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stdout, $pattern, 1, 0, $name || 'stdout matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stdout_unlike
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stdout, $pattern, 1, 1, $name || 'stdout does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stderr_is
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stderr, $pattern, 0, 0, $name || 'stderr matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stderr_isnt
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stderr, $pattern, 0, 1, $name || 'stderr does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stderr_like
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stderr, $pattern, 1, 0, $name || 'stderr matches' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
sub program_stderr_unlike
|
||||
{
|
||||
my($pattern, $name) = @_;
|
||||
@_ = ($program_stderr, $pattern, 1, 1, $name || 'stderr does not match' );
|
||||
goto &_like;
|
||||
}
|
||||
|
||||
|
||||
######################################################################
|
||||
# Support Functions
|
||||
|
||||
# Script params must be either a simple non-null string with the script
|
||||
# name, or an array reference with one or more non-null strings.
|
||||
sub _script {
|
||||
my $in = shift;
|
||||
if ( defined _STRING($in) ) {
|
||||
return [ $in ];
|
||||
}
|
||||
if ( _ARRAY($in) ) {
|
||||
unless ( scalar grep { not defined _STRING($_) } @$in ) {
|
||||
return [ @$in ];
|
||||
}
|
||||
}
|
||||
croak("Invalid command parameter");
|
||||
}
|
||||
|
||||
# Determine any extra arguments that need to be passed into Perl.
|
||||
# ATM this is just -T.
|
||||
sub _perl_args {
|
||||
my($script) = @_;
|
||||
my $fh;
|
||||
my $first_line = '';
|
||||
if(open($fh, '<', $script))
|
||||
{
|
||||
$first_line = <$fh>;
|
||||
close $fh;
|
||||
}
|
||||
(grep /^-.*T/, split /\s+/, $first_line) ? ['-T'] : [];
|
||||
}
|
||||
|
||||
# Inline some basic Params::Util functions
|
||||
|
||||
sub _options {
|
||||
my $ref_stdout = shift;
|
||||
my $ref_stderr = shift;
|
||||
my $permit_interpreter_options = shift;
|
||||
my %options = ref($_[0]->[0]) eq 'HASH' ? %{ shift @{ $_[0] } }: ();
|
||||
|
||||
$options{exit} = 0 unless defined $options{exit};
|
||||
$options{signal} = 0 unless defined $options{signal};
|
||||
my $stdin = '';
|
||||
#$options{stdin} = \$stdin unless defined $options{stdin};
|
||||
$options{stdout} = $ref_stdout unless defined $options{stdout};
|
||||
$options{stderr} = $ref_stderr unless defined $options{stderr};
|
||||
|
||||
if(defined $options{interpreter_options})
|
||||
{
|
||||
die "interpreter_options not supported" unless $permit_interpreter_options;
|
||||
unless(ref $options{interpreter_options} eq 'ARRAY')
|
||||
{
|
||||
require Text::ParseWords;
|
||||
$options{interpreter_options} = [ Text::ParseWords::shellwords($options{interpreter_options}) ];
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$options{interpreter_options} = [];
|
||||
}
|
||||
|
||||
\%options;
|
||||
}
|
||||
|
||||
sub _ARRAY ($) {
|
||||
(ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _STRING ($) {
|
||||
(defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
# Alias to old name
|
||||
*script_compiles_ok = *script_compiles;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Script - Basic cross-platform tests for scripts
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.26
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test::Script;
|
||||
|
||||
script_compiles('script/myscript.pl');
|
||||
script_runs(['script/myscript.pl', '--my-argument']);
|
||||
|
||||
program_runs(['ls', '/dev']);
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The intent of this module is to provide a series of basic tests for 80%
|
||||
of the testing you will need to do for scripts in the F<script> (or F<bin>
|
||||
as is also commonly used) paths of your Perl distribution.
|
||||
|
||||
It also provides similar functions for testing programs that are not
|
||||
Perl scripts.
|
||||
|
||||
Further, it aims to provide this functionality with perfect
|
||||
platform-compatibility, and in a way that is as unobtrusive as possible.
|
||||
|
||||
That is, if the program works on a platform, then B<Test::Script>
|
||||
should always work on that platform as well. Anything less than 100% is
|
||||
considered unacceptable.
|
||||
|
||||
In doing so, it is hoped that B<Test::Script> can become a module that
|
||||
you can safely make a dependency of all your modules, without risking that
|
||||
your module won't on some platform because of the dependency.
|
||||
|
||||
Where a clash exists between wanting more functionality and maintaining
|
||||
platform safety, this module will err on the side of platform safety.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 script_compiles
|
||||
|
||||
script_compiles( $script, $test_name );
|
||||
|
||||
The L</script_compiles> test calls the script with "perl -c script.pl",
|
||||
and checks that it returns without error.
|
||||
|
||||
The path it should be passed is a relative Unix-format script name. This
|
||||
will be localised when running C<perl -c> and if the test fails the local
|
||||
name used will be shown in the diagnostic output.
|
||||
|
||||
Note also that the test will be run with the same L<perl> interpreter that
|
||||
is running the test script (and not with the default system perl). This
|
||||
will also be shown in the diagnostic output on failure.
|
||||
|
||||
=head2 script_runs
|
||||
|
||||
script_runs( $script, $test_name );
|
||||
script_runs( \@script_and_arguments, $test_name );
|
||||
script_runs( $script, \%options, $test_name );
|
||||
script_runs( \@script_and_arguments, \%options, $test_name );
|
||||
|
||||
The L</script_runs> test executes the script with "perl script.pl" and checks
|
||||
that it returns success.
|
||||
|
||||
The path it should be passed is a relative unix-format script name. This
|
||||
will be localised when running C<perl -c> and if the test fails the local
|
||||
name used will be shown in the diagnostic output.
|
||||
|
||||
The test will be run with the same L<perl> interpreter that is running the
|
||||
test script (and not with the default system perl). This will also be shown
|
||||
in the diagnostic output on failure.
|
||||
|
||||
You may pass in options as a hash as the second argument.
|
||||
|
||||
=over 4
|
||||
|
||||
=item exit
|
||||
|
||||
The expected exit value. The default is to use whatever indicates success
|
||||
on your platform (usually 0).
|
||||
|
||||
=item interpreter_options
|
||||
|
||||
Array reference of Perl options to be passed to the interpreter. Things
|
||||
like C<-w> or C<-x> can be passed this way. This may be either a single
|
||||
string or an array reference.
|
||||
|
||||
=item signal
|
||||
|
||||
The expected signal. The default is 0. Use with care! This may not be
|
||||
portable, and is known not to work on Windows.
|
||||
|
||||
=item stdin
|
||||
|
||||
The input to be passed into the script via stdin. The value may be one of
|
||||
|
||||
=over 4
|
||||
|
||||
=item simple scalar
|
||||
|
||||
Is considered to be a filename.
|
||||
|
||||
=item scalar reference
|
||||
|
||||
In which case the input will be drawn from the data contained in the referenced
|
||||
scalar.
|
||||
|
||||
=back
|
||||
|
||||
The behavior for any other types is undefined (the current implementation uses
|
||||
L<Capture::Tiny>). Any already opened stdin will be closed.
|
||||
|
||||
=item stdout
|
||||
|
||||
Where to send the standard output to. If you use this option, then the the
|
||||
behavior of the C<script_stdout_> functions below are undefined. The value
|
||||
may be one of
|
||||
|
||||
=over 4
|
||||
|
||||
=item simple scalar
|
||||
|
||||
Is considered to be a filename.
|
||||
|
||||
=item scalar reference
|
||||
|
||||
=back
|
||||
|
||||
In which case the standard output will be places into the referenced scalar
|
||||
|
||||
The behavior for any other types is undefined (the current implementation uses
|
||||
L<Capture::Tiny>).
|
||||
|
||||
=item stderr
|
||||
|
||||
Same as C<stdout> above, except for stderr.
|
||||
|
||||
=back
|
||||
|
||||
=head2 script_stdout_is
|
||||
|
||||
script_stdout_is $expected_stdout, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</script_runs> matches the
|
||||
expected value exactly.
|
||||
|
||||
=head2 script_stdout_isnt
|
||||
|
||||
script_stdout_is $expected_stdout, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</script_runs> does NOT match the
|
||||
expected value exactly.
|
||||
|
||||
=head2 script_stdout_like
|
||||
|
||||
script_stdout_like $regex, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</script_runs> matches the regular
|
||||
expression.
|
||||
|
||||
=head2 script_stdout_unlike
|
||||
|
||||
script_stdout_unlike $regex, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</script_runs> does NOT match the regular
|
||||
expression.
|
||||
|
||||
=head2 script_stderr_is
|
||||
|
||||
script_stderr_is $expected_stderr, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</script_runs> matches the
|
||||
expected value exactly.
|
||||
|
||||
=head2 script_stderr_isnt
|
||||
|
||||
script_stderr_is $expected_stderr, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</script_runs> does NOT match the
|
||||
expected value exactly.
|
||||
|
||||
=head2 script_stderr_like
|
||||
|
||||
script_stderr_like $regex, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</script_runs> matches the regular
|
||||
expression.
|
||||
|
||||
=head2 script_stderr_unlike
|
||||
|
||||
script_stderr_unlike $regex, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</script_runs> does NOT match the regular
|
||||
expression.
|
||||
|
||||
=head2 program_runs
|
||||
|
||||
program_runs( $program, $test_name );
|
||||
program_runs( \@program_and_arguments, $test_name );
|
||||
program_runs( $program, \%options, $test_name );
|
||||
program_runs( \@program_and_arguments, \%options, $test_name );
|
||||
|
||||
The L</program_runs> test executes the given program and checks
|
||||
that it returns success. This function works like L</script_runs> except:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
The path C<$program> or C<@program_and_arguments> is passed as-is to
|
||||
L<system()|https://perldoc.perl.org/functions/system.html>. This means
|
||||
C<program_runs> can test any program, not just Perl scripts.
|
||||
|
||||
=item *
|
||||
|
||||
The C<%options> do not support the C<interpreter_options> key.
|
||||
|
||||
=back
|
||||
|
||||
See L<File::Spec> or L<Path::Class> for routines useful in building pathnames
|
||||
in a cross-platform way.
|
||||
|
||||
=head2 program_stdout_is
|
||||
|
||||
program_stdout_is $expected_stdout, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</program_runs> matches the
|
||||
expected value exactly.
|
||||
|
||||
=head2 program_stdout_isnt
|
||||
|
||||
program_stdout_is $expected_stdout, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</program_runs> does NOT match the
|
||||
expected value exactly.
|
||||
|
||||
=head2 program_stdout_like
|
||||
|
||||
program_stdout_like $regex, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</program_runs> matches the regular
|
||||
expression.
|
||||
|
||||
=head2 program_stdout_unlike
|
||||
|
||||
program_stdout_unlike $regex, $test_name;
|
||||
|
||||
Tests if the output to stdout from the previous L</program_runs> does NOT match the regular
|
||||
expression.
|
||||
|
||||
=head2 program_stderr_is
|
||||
|
||||
program_stderr_is $expected_stderr, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</program_runs> matches the
|
||||
expected value exactly.
|
||||
|
||||
=head2 program_stderr_isnt
|
||||
|
||||
program_stderr_is $expected_stderr, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</program_runs> does NOT match the
|
||||
expected value exactly.
|
||||
|
||||
=head2 program_stderr_like
|
||||
|
||||
program_stderr_like $regex, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</program_runs> matches the regular
|
||||
expression.
|
||||
|
||||
=head2 program_stderr_unlike
|
||||
|
||||
program_stderr_unlike $regex, $test_name;
|
||||
|
||||
Tests if the output to stderr from the previous L</program_runs> does NOT match the regular
|
||||
expression.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
This module is fully supported back to Perl 5.8.1.
|
||||
|
||||
The STDIN handle will be closed when using script_runs with the stdin option.
|
||||
An older version used L<IPC::Run3>, which attempted to save STDIN, but
|
||||
apparently this cannot be done consistently or portably. We now use
|
||||
L<Capture::Tiny> instead and explicitly do not support saving STDIN handles.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test::Script::Run>, L<Test2::Suite>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Original author: Adam Kennedy
|
||||
|
||||
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Brendan Byrd
|
||||
|
||||
Chris White E<lt>cxw@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2019 by Adam Kennedy.
|
||||
|
||||
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
|
||||
1560
database/perl/vendor/lib/Test/Specio.pm
vendored
Normal file
1560
database/perl/vendor/lib/Test/Specio.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
221
database/perl/vendor/lib/Test/SubCalls.pm
vendored
Normal file
221
database/perl/vendor/lib/Test/SubCalls.pm
vendored
Normal file
@@ -0,0 +1,221 @@
|
||||
package Test::SubCalls; # git description: d4e5915
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::SubCalls - Track the number of times subs are called
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.10
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::SubCalls;
|
||||
|
||||
# Start tracking calls to a named sub
|
||||
sub_track( 'Foo::foo' );
|
||||
|
||||
# Run some test code
|
||||
...
|
||||
|
||||
# Test that some sub deep in the codebase was called
|
||||
# a specific number of times.
|
||||
sub_calls( 'Foo::foo', 5 );
|
||||
sub_calls( 'Foo::foo', 5, 'Use a custom test message' );
|
||||
|
||||
# Reset the counts for one or all subs
|
||||
sub_reset( 'Foo::foo' );
|
||||
sub_reset_all();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
There are a number of different situations (like testing caching code)
|
||||
where you want to want to do a number of tests, and then verify that
|
||||
some underlying subroutine deep within the code was called a specific
|
||||
number of times.
|
||||
|
||||
This module provides a number of functions for doing testing in this way
|
||||
in association with your normal L<Test::More> (or similar) test scripts.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
In the nature of test modules, all functions are exported by default.
|
||||
|
||||
=cut
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use File::Spec 0.80 ();
|
||||
use Test::More 0.42 ();
|
||||
use Hook::LexWrap 0.20 ();
|
||||
use Exporter ();
|
||||
use Test::Builder ();
|
||||
|
||||
our $VERSION = '1.10';
|
||||
use vars qw{@ISA @EXPORT};
|
||||
BEGIN {
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT = qw{sub_track sub_calls sub_reset sub_reset_all};
|
||||
}
|
||||
|
||||
my $Test = Test::Builder->new;
|
||||
|
||||
my %CALLS = ();
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Test::SubCalls Functions
|
||||
|
||||
=pod
|
||||
|
||||
=head2 sub_track $subname
|
||||
|
||||
The C<sub_track> function creates a new call tracker for a named function.
|
||||
|
||||
The sub to track must be provided by name, references to the function
|
||||
itself are insufficient.
|
||||
|
||||
Returns true if added, or dies on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub sub_track {
|
||||
# Check the sub name is valid
|
||||
my $subname = shift;
|
||||
SCOPE: {
|
||||
no strict 'refs';
|
||||
unless ( defined *{"$subname"}{CODE} ) {
|
||||
die "Test::SubCalls::sub_track : The sub '$subname' does not exist";
|
||||
}
|
||||
if ( defined $CALLS{$subname} ) {
|
||||
die "Test::SubCalls::sub_track : Cannot add duplicate tracker for '$subname'";
|
||||
}
|
||||
}
|
||||
|
||||
# Initialise the count
|
||||
$CALLS{$subname} = 0;
|
||||
|
||||
# Lexwrap the subroutine
|
||||
Hook::LexWrap::wrap(
|
||||
$subname,
|
||||
pre => sub { $CALLS{$subname}++ },
|
||||
);
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 sub_calls $subname, $expected_calls [, $message ]
|
||||
|
||||
The C<sub_calls> function is the primary (and only) testing function
|
||||
provided by C<Test::SubCalls>. A single call will represent one test in
|
||||
your plan.
|
||||
|
||||
It takes the subroutine name as originally provided to C<sub_track>,
|
||||
the expected number of times the subroutine should have been called,
|
||||
and an optional test message.
|
||||
|
||||
If no message is provided, a default message will be provided for you.
|
||||
|
||||
Test is ok if the number of times the sub has been called matches the
|
||||
expected number, or not ok if not.
|
||||
|
||||
=cut
|
||||
|
||||
sub sub_calls {
|
||||
# Check the sub name is valid
|
||||
my $subname = shift;
|
||||
unless ( defined $CALLS{$subname} ) {
|
||||
die "Test::SubCalls::sub_calls : Cannot test untracked sub '$subname'";
|
||||
}
|
||||
|
||||
# Check the count
|
||||
my $count = shift;
|
||||
unless ( $count =~ /^(?:0|[1-9]\d*)\z/s ) {
|
||||
die "Test::SubCalls::sub_calls : Expected count '$count' is not an integer";
|
||||
}
|
||||
|
||||
# Get the message, applying default if needed
|
||||
my $message = shift || "$subname was called $count times";
|
||||
$Test->is_num( $CALLS{$subname}, $count, $message );
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 sub_reset $subname
|
||||
|
||||
To prevent repeat users from having to take before and after counts when
|
||||
they start testing from after zero, the C<sub_reset> function has been
|
||||
provided to reset a sub call counter to zero.
|
||||
|
||||
Returns true or dies if the sub name is invalid or not currently tracked.
|
||||
|
||||
=cut
|
||||
|
||||
sub sub_reset {
|
||||
# Check the sub name is valid
|
||||
my $subname = shift;
|
||||
unless ( defined $CALLS{$subname} ) {
|
||||
die "Test::SubCalls::sub_reset : Cannot reset untracked sub '$subname'";
|
||||
}
|
||||
|
||||
$CALLS{$subname} = 0;
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 sub_reset_all
|
||||
|
||||
Provided mainly as a convenience, the C<sub_reset_all> function will reset
|
||||
all the counters currently defined.
|
||||
|
||||
Returns true.
|
||||
|
||||
=cut
|
||||
|
||||
sub sub_reset_all {
|
||||
foreach my $subname ( keys %CALLS ) {
|
||||
$CALLS{$subname} = 0;
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs should be submitted via the CPAN bug tracker, located at
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-SubCalls>
|
||||
|
||||
For other issues, or commercial enhancement or support, contact the author.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://ali.as/>, L<Test::Builder>, L<Test::More>, L<Hook::LexWrap>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2009 Adam Kennedy.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
504
database/perl/vendor/lib/Test/Warn.pm
vendored
Normal file
504
database/perl/vendor/lib/Test/Warn.pm
vendored
Normal file
@@ -0,0 +1,504 @@
|
||||
=head1 NAME
|
||||
|
||||
Test::Warn - Perl extension to test methods for warnings
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Warn;
|
||||
|
||||
warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning";
|
||||
warnings_are {bar(1,1)} ["Width very small", "Height very small"];
|
||||
|
||||
warning_is {add(2,2)} undef, "No warnings for calc 2+2"; # or
|
||||
warnings_are {add(2,2)} [], "No warnings for calc 2+2"; # whichever reads better :-)
|
||||
|
||||
warning_like {foo(-dri => "/")} qr/unknown param/i, "an unknown parameter test";
|
||||
warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i];
|
||||
|
||||
warning_is {foo()} {carped => "didn't find the right parameters"};
|
||||
warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}];
|
||||
|
||||
warning_like {foo(undef)} 'uninitialized';
|
||||
warning_like {bar(file => '/etc/passwd')} 'io';
|
||||
|
||||
warning_like {eval q/"$x"; $x;/}
|
||||
[qw/void uninitialized/],
|
||||
"some warnings at compile time";
|
||||
|
||||
warnings_exist {...} [qr/expected warning/], "Expected warning is thrown";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A good style of Perl programming calls for a lot of diverse regression tests.
|
||||
|
||||
This module provides a few convenience methods for testing warning based-code.
|
||||
|
||||
If you are not already familiar with the L<Test::More> manpage
|
||||
now would be the time to go take a look.
|
||||
|
||||
=head2 FUNCTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<warning_is> I<BLOCK STRING, TEST_NAME>
|
||||
|
||||
Tests that BLOCK gives the specified warning exactly once.
|
||||
|
||||
The test fails if the BLOCK warns more than once or does not warn at all.
|
||||
If the string is undef, then the test succeeds if the BLOCK doesn't
|
||||
give any warning.
|
||||
|
||||
Another way to say that there are no warnings in the block
|
||||
is:
|
||||
|
||||
warnings_are {foo()} [], "no warnings"
|
||||
|
||||
If you want to test for a warning given by Carp
|
||||
you have to write something like:
|
||||
|
||||
warning_is {carp "msg"} {carped => 'msg'}, "Test for a carped warning";
|
||||
|
||||
The test will fail if a "normal" warning is found instead of a "carped" one.
|
||||
|
||||
Note: C<warn "foo"> would print something like C<foo at -e line 1>.
|
||||
This method ignores everything after the "at". Thus to match this warning
|
||||
you would have to call C<< warning_is {warn "foo"} "foo", "Foo succeeded" >>.
|
||||
If you need to test for a warning at an exact line,
|
||||
try something like:
|
||||
|
||||
warning_like {warn "foo"} qr/at XYZ.dat line 5/
|
||||
|
||||
Warn messages with a trailing newline (like C<warn "foo\n">) don't produce the C<at -e line 1> message by Perl.
|
||||
Up to Test::Warn 0.30 such warning weren't supported by C<< warning_is {warn "foo\n"} "foo\n" >>.
|
||||
Starting with version 0.31 they are supported, but also marked as experimental.
|
||||
|
||||
L<C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME> and L<C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME>
|
||||
are only aliases to the same method. So you also could write
|
||||
C<< warning_is {foo()} [], "no warning" >> or something similar.
|
||||
|
||||
I decided to give two methods the same name to improve readability.
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise.
|
||||
|
||||
The test name is optional, but recommended.
|
||||
|
||||
=item B<warnings_are> I<BLOCK ARRAYREF, TEST_NAME>
|
||||
|
||||
Tests to see that BLOCK gives exactly the specified warnings.
|
||||
The test fails if the warnings from BLOCK are not exactly the ones in ARRAYREF.
|
||||
If the ARRAYREF is equal to C<< [] >>,
|
||||
then the test succeeds if the BLOCK doesn't give any warning.
|
||||
|
||||
Please read also the notes to
|
||||
L<C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME>
|
||||
as these methods are only aliases.
|
||||
|
||||
If you want more than one test for carped warnings, try this:
|
||||
|
||||
warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];
|
||||
|
||||
or
|
||||
|
||||
warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"];
|
||||
|
||||
Note that C<< {carped => ...} >> must always be a hash ref.
|
||||
|
||||
=item B<warning_like> I<BLOCK REGEXP, TEST_NAME>
|
||||
|
||||
Tests that BLOCK gives exactly one warning and it can be matched by
|
||||
the given regexp.
|
||||
|
||||
If the string is undef, then the tests succeeds if the BLOCK doesn't
|
||||
give any warning.
|
||||
|
||||
The REGEXP is matched against the whole warning line,
|
||||
which in general has the form C<< "WARNING at __FILE__ line __LINE__" >>.
|
||||
So you can check for a warning in the file C<Foo.pm> on line 5 with:
|
||||
|
||||
warning_like {bar()} qr/at Foo.pm line 5/, "Testname"
|
||||
|
||||
I don't know whether it makes sense to do such a test :-(
|
||||
|
||||
However, you should be prepared as a matching with C<'at'>, C<'file'>, C<'\d'>
|
||||
or similar will always pass.
|
||||
|
||||
Consider C<< qr/^foo/ >> if you want to test for warning C<"foo something"> in file F<foo.pl>.
|
||||
|
||||
You can also write the regexp in a string as C<"/.../">
|
||||
instead of using the C<< qr/.../ >> syntax.
|
||||
|
||||
Note that the slashes are important in the string,
|
||||
as strings without slashes are reserved for warning categories
|
||||
(to match warning categories as can be seen in the perllexwarn man page).
|
||||
|
||||
Similar to
|
||||
L<< C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME >> and
|
||||
L<< C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>
|
||||
you can test for warnings via C<carp> with:
|
||||
|
||||
warning_like {bar()} {carped => qr/bar called too early/i};
|
||||
|
||||
Similar to
|
||||
L<< C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME >> and
|
||||
L<< C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>,
|
||||
|
||||
L<< C<warning_like()>|/warning_like-BLOCK-REGEXP-TEST_NAME >> and
|
||||
L<< C<warnings_like()>|/warnings_like-BLOCK-ARRAYREF-TEST_NAME >>
|
||||
are only aliases to the same methods.
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise.
|
||||
|
||||
The test name is optional, but recommended.
|
||||
|
||||
=item B<warning_like> I<BLOCK STRING, TEST_NAME>
|
||||
|
||||
Tests whether a BLOCK gives exactly one warning of the passed category.
|
||||
|
||||
The categories are grouped in a tree,
|
||||
like it is expressed in L<perllexwarn>.
|
||||
Also see L</BUGS AND LIMITATIONS>.
|
||||
|
||||
|
||||
Thanks to the grouping in a tree,
|
||||
it's possible to test simply for an 'io' warning,
|
||||
instead of testing for a 'closed|exec|layer|newline|pipe|unopened' warning.
|
||||
|
||||
Note, that warnings occurring at compile time
|
||||
can only be caught in an eval block. So
|
||||
|
||||
warning_like {eval q/"$x"; $x;/}
|
||||
[qw/void uninitialized/],
|
||||
"some warnings at compile time";
|
||||
|
||||
will work, while it wouldn't work without the eval.
|
||||
|
||||
Note, that it isn't possible yet,
|
||||
to test for own categories,
|
||||
created with L<warnings::register>.
|
||||
|
||||
=item B<warnings_like> I<BLOCK ARRAYREF, TEST_NAME>
|
||||
|
||||
Tests to see that BLOCK gives exactly the number of the specified
|
||||
warnings, in the defined order.
|
||||
|
||||
Please read also the notes to
|
||||
L<< C<warning_like()>|/warning_like-BLOCK-REGEXP-TEST_NAME >>
|
||||
as these methods are only aliases.
|
||||
|
||||
Similar to
|
||||
L<< C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>,
|
||||
you can test for multiple warnings via C<carp>
|
||||
and for warning categories, too:
|
||||
|
||||
warnings_like {foo()}
|
||||
[qr/bar warning/,
|
||||
qr/bar warning/,
|
||||
{carped => qr/bar warning/i},
|
||||
'io'
|
||||
],
|
||||
"I hope you'll never have to write a test for so many warnings :-)";
|
||||
|
||||
=item B<warnings_exist> I<BLOCK STRING|ARRAYREF, TEST_NAME>
|
||||
|
||||
Same as warning_like, but will C<< warn() >> all warnings that do not match the supplied regex/category,
|
||||
instead of registering an error. Use this test when you just want to make sure that specific
|
||||
warnings were generated, and couldn't care less if other warnings happened in the same block
|
||||
of code.
|
||||
|
||||
warnings_exist {...} [qr/expected warning/], "Expected warning is thrown";
|
||||
|
||||
warnings_exist {...} ['uninitialized'], "Expected warning is thrown";
|
||||
|
||||
=back
|
||||
|
||||
=head2 EXPORT
|
||||
|
||||
C<warning_is>,
|
||||
C<warnings_are>,
|
||||
C<warning_like>,
|
||||
C<warnings_like>,
|
||||
C<warnings_exist> by default.
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
Category check is done as C<< qr/category_name/ >>. In some case this works, like for
|
||||
category C<'uninitialized'>. For C<'utf8'> it does not work. Perl does not have a list
|
||||
of warnings, so it is not possible to generate one for C<Test::Warn>.
|
||||
|
||||
If you want to add a warning to a category, send a pull request. Modifications
|
||||
should be done to C<< %warnings_in_category >>. You should look into perl source to check
|
||||
how warning is looking exactly.
|
||||
|
||||
Please note that warnings with newlines inside are very awkward.
|
||||
The only sensible way to handle them is to use the C<warning_like> or
|
||||
C<warnings_like> methods. The background is that there is no
|
||||
really safe way to distinguish between warnings with newlines and a
|
||||
stacktrace.
|
||||
|
||||
If a method has its own warn handler,
|
||||
overwriting C<$SIG{__WARN__}>,
|
||||
my test warning methods won't get these warnings.
|
||||
|
||||
The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't fully tested.
|
||||
Please take note if you use this this calling style,
|
||||
and report any bugs you find.
|
||||
|
||||
=head2 XS warnings
|
||||
|
||||
As described in https://rt.cpan.org/Ticket/Display.html?id=42070&results=3c71d1b101a730e185691657f3b02f21 or https://github.com/hanfried/test-warn/issues/1 XS warnings might not be caught.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Have a look to the similar L<Test::Exception> module. L<Test::Trap>
|
||||
|
||||
=head1 THANKS
|
||||
|
||||
Many thanks to Adrian Howard, chromatic and Michael G. Schwern,
|
||||
who have given me a lot of ideas.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2002 by Janek Schleicher
|
||||
|
||||
Copyright 2007-2014 by Alexandr Ciornii, L<http://chorny.net/>
|
||||
|
||||
Copyright 2015-2018 by Janek Schleicher
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
package Test::Warn;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sub::Uplevel 0.12;
|
||||
|
||||
our $VERSION = '0.36';
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our %EXPORT_TAGS = ( 'all' => [ qw(
|
||||
@EXPORT
|
||||
) ] );
|
||||
|
||||
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
|
||||
|
||||
our @EXPORT = qw(
|
||||
warning_is warnings_are
|
||||
warning_like warnings_like
|
||||
warnings_exist
|
||||
);
|
||||
|
||||
use Test::Builder;
|
||||
my $Tester = Test::Builder->new;
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
*warning_is = *warnings_are;
|
||||
*warning_like = *warnings_like;
|
||||
}
|
||||
|
||||
sub warnings_are (&$;$) {
|
||||
my $block = shift;
|
||||
my @exp_warning = map {_canonical_exp_warning($_)}
|
||||
_to_array_if_necessary( shift() || [] );
|
||||
my $testname = shift;
|
||||
my @got_warning = ();
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($called_from) = caller(0); # to find out Carping methods
|
||||
push @got_warning, _canonical_got_warning($called_from, shift());
|
||||
};
|
||||
uplevel 1,$block;
|
||||
my $ok = _cmp_is( \@got_warning, \@exp_warning );
|
||||
$Tester->ok( $ok, $testname );
|
||||
$ok or _diag_found_warning(@got_warning),
|
||||
_diag_exp_warning(@exp_warning);
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub warnings_like (&$;$) {
|
||||
my $block = shift;
|
||||
my @exp_warning = map {_canonical_exp_warning($_)}
|
||||
_to_array_if_necessary( shift() || [] );
|
||||
my $testname = shift;
|
||||
my @got_warning = ();
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($called_from) = caller(0); # to find out Carping methods
|
||||
push @got_warning, _canonical_got_warning($called_from, shift());
|
||||
};
|
||||
uplevel 1,$block;
|
||||
my $ok = _cmp_like( \@got_warning, \@exp_warning );
|
||||
$Tester->ok( $ok, $testname );
|
||||
$ok or _diag_found_warning(@got_warning),
|
||||
_diag_exp_warning(@exp_warning);
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub warnings_exist (&$;$) {
|
||||
my $block = shift;
|
||||
my @exp_warning = map {_canonical_exp_warning($_)}
|
||||
_to_array_if_necessary( shift() || [] );
|
||||
my $testname = shift;
|
||||
my @got_warning = ();
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($called_from) = caller(0); # to find out Carping methods
|
||||
my $wrn_text=shift;
|
||||
my $wrn_rec=_canonical_got_warning($called_from, $wrn_text);
|
||||
foreach my $wrn (@exp_warning) {
|
||||
if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) {
|
||||
push @got_warning, $wrn_rec;
|
||||
return;
|
||||
}
|
||||
}
|
||||
warn $wrn_text;
|
||||
};
|
||||
uplevel 1,$block;
|
||||
my $ok = _cmp_like( \@got_warning, \@exp_warning );
|
||||
$Tester->ok( $ok, $testname );
|
||||
$ok or _diag_found_warning(@got_warning),
|
||||
_diag_exp_warning(@exp_warning);
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub _to_array_if_necessary {
|
||||
return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
|
||||
}
|
||||
|
||||
sub _canonical_got_warning {
|
||||
my ($called_from, $msg) = @_;
|
||||
my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn';
|
||||
my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
|
||||
return {$warn_kind => $warning_stack[0]}; # return only the real message
|
||||
}
|
||||
|
||||
sub _canonical_exp_warning {
|
||||
my ($exp) = @_;
|
||||
if (ref($exp) eq 'HASH') { # could be {carped => ...}
|
||||
my $to_carp = $exp->{carped} or return; # undefined message are ignored
|
||||
return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] }
|
||||
? map({ {carped => $_} } grep {defined $_} @$to_carp)
|
||||
: +{carped => $to_carp};
|
||||
}
|
||||
return {warn => $exp};
|
||||
}
|
||||
|
||||
sub _cmp_got_to_exp_warning {
|
||||
my ($got_kind, $got_msg) = %{ shift() };
|
||||
my ($exp_kind, $exp_msg) = %{ shift() };
|
||||
return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
|
||||
my $cmp;
|
||||
if ($exp_msg =~ /\n$/s) {
|
||||
$cmp = "$got_msg\n" eq $exp_msg;
|
||||
} else {
|
||||
$cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/s;
|
||||
}
|
||||
return $cmp;
|
||||
}
|
||||
|
||||
sub _cmp_got_to_exp_warning_like {
|
||||
my ($got_kind, $got_msg) = %{ shift() };
|
||||
my ($exp_kind, $exp_msg) = %{ shift() };
|
||||
return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
|
||||
if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//'
|
||||
my $cmp = $got_msg =~ /$re/;
|
||||
return $cmp;
|
||||
} else {
|
||||
return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _cmp_is {
|
||||
my @got = @{ shift() };
|
||||
my @exp = @{ shift() };
|
||||
scalar @got == scalar @exp or return 0;
|
||||
my $cmp = 1;
|
||||
$cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
|
||||
return $cmp;
|
||||
}
|
||||
|
||||
sub _cmp_like {
|
||||
my @got = @{ shift() };
|
||||
my @exp = @{ shift() };
|
||||
scalar @got == scalar @exp or return 0;
|
||||
my $cmp = 1;
|
||||
$cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
|
||||
return $cmp;
|
||||
}
|
||||
|
||||
sub _diag_found_warning {
|
||||
foreach (@_) {
|
||||
if (ref($_) eq 'HASH') {
|
||||
${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
|
||||
: $Tester->diag("found warning: ${$_}{warn}");
|
||||
} else {
|
||||
$Tester->diag( "found warning: $_" );
|
||||
}
|
||||
}
|
||||
$Tester->diag( "didn't find a warning" ) unless @_;
|
||||
}
|
||||
|
||||
sub _diag_exp_warning {
|
||||
foreach (@_) {
|
||||
if (ref($_) eq 'HASH') {
|
||||
${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
|
||||
: $Tester->diag("expected to find warning: ${$_}{warn}");
|
||||
} else {
|
||||
$Tester->diag( "expected to find warning: $_" );
|
||||
}
|
||||
}
|
||||
$Tester->diag( "didn't expect to find a warning" ) unless @_;
|
||||
}
|
||||
|
||||
package Test::Warn::Categorization;
|
||||
|
||||
use Carp;
|
||||
|
||||
my $bits = \%warnings::Bits;
|
||||
my @warnings = sort grep {
|
||||
my $warn_bits = $bits->{$_};
|
||||
#!grep { $_ ne $warn_bits && ($_ & $warn_bits) eq $_ } values %$bits;
|
||||
} keys %$bits;
|
||||
|
||||
# Create a warning name category (e.g. 'utf8') to map to a list of warnings.
|
||||
# The warnings are strings that will be OR'ed together into a
|
||||
# regular expression: qr/...|...|.../.
|
||||
my %warnings_in_category = (
|
||||
'utf8' => ['Wide character in \w+\b',],
|
||||
);
|
||||
|
||||
sub _warning_category_regexp {
|
||||
my $category = shift;
|
||||
my $category_bits = $bits->{$category} or return;
|
||||
my @category_warnings
|
||||
= grep { ($bits->{$_} & $category_bits) eq $bits->{$_} } @warnings;
|
||||
|
||||
my @list =
|
||||
map { exists $warnings_in_category{$_}? (@{ $warnings_in_category{$_}}) : ($_) }
|
||||
@category_warnings;
|
||||
my $re = join "|", @list;
|
||||
return qr/$re/;
|
||||
}
|
||||
|
||||
sub warning_like_category {
|
||||
my ($warning, $category) = @_;
|
||||
my $re = _warning_category_regexp($category) or
|
||||
carp("Unknown warning category '$category'"),return;
|
||||
my $ok = $warning =~ /$re/;
|
||||
return $ok;
|
||||
}
|
||||
|
||||
1;
|
||||
187
database/perl/vendor/lib/Test/Without/Module.pm
vendored
Normal file
187
database/perl/vendor/lib/Test/Without/Module.pm
vendored
Normal file
@@ -0,0 +1,187 @@
|
||||
package Test::Without::Module;
|
||||
use strict;
|
||||
use Carp qw( croak );
|
||||
|
||||
use vars qw( $VERSION );
|
||||
$VERSION = '0.20';
|
||||
|
||||
use vars qw(%forbidden);
|
||||
|
||||
sub get_forbidden_list {
|
||||
\%forbidden
|
||||
};
|
||||
|
||||
sub import {
|
||||
my ($self,@forbidden_modules) = @_;
|
||||
|
||||
my $forbidden = get_forbidden_list;
|
||||
|
||||
for (@forbidden_modules) {
|
||||
my $file = module2file($_);
|
||||
$forbidden->{$file} = delete $INC{$file};
|
||||
};
|
||||
|
||||
# Scrub %INC, so that loaded modules disappear
|
||||
for my $module (@forbidden_modules) {
|
||||
scrub( $module );
|
||||
};
|
||||
|
||||
@INC = (\&fake_module, grep { !ref || $_ != \&fake_module } @INC);
|
||||
};
|
||||
|
||||
sub fake_module {
|
||||
my ($self,$module_file,$member_only) = @_;
|
||||
# Don't touch $@, or .al files will not load anymore????
|
||||
|
||||
if (exists get_forbidden_list->{$module_file}) {
|
||||
my $module_name = file2module($module_file);
|
||||
croak "Can't locate $module_file in \@INC (you may need to install the $module_name module) (\@INC contains: @INC)";
|
||||
};
|
||||
};
|
||||
|
||||
sub unimport {
|
||||
my ($self,@list) = @_;
|
||||
my $module;
|
||||
my $forbidden = get_forbidden_list;
|
||||
|
||||
for $module (@list) {
|
||||
my $file = module2file($module);
|
||||
if (exists $forbidden->{$file}) {
|
||||
my $path = delete $forbidden->{$file};
|
||||
if (defined $path) {
|
||||
$INC{ $file } = $path;
|
||||
}
|
||||
} else {
|
||||
croak "Can't allow non-forbidden module $module";
|
||||
};
|
||||
};
|
||||
};
|
||||
|
||||
sub file2module {
|
||||
my ($mod) = @_;
|
||||
$mod =~ s!/!::!g;
|
||||
$mod =~ s!\.pm$!!;
|
||||
$mod;
|
||||
};
|
||||
|
||||
sub module2file {
|
||||
my ($mod) = @_;
|
||||
$mod =~ s!::|'!/!g;
|
||||
$mod .= ".pm";
|
||||
$mod;
|
||||
};
|
||||
|
||||
sub scrub {
|
||||
my ($module) = @_;
|
||||
delete $INC{module2file($module)};
|
||||
};
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Without::Module - Test fallback behaviour in absence of modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=for example begin
|
||||
|
||||
use Test::Without::Module qw( My::Module );
|
||||
|
||||
# Now, loading of My::Module fails :
|
||||
eval { require My::Module; };
|
||||
warn $@ if $@;
|
||||
|
||||
# Now it works again
|
||||
eval q{ no Test::Without::Module qw( My::Module ) };
|
||||
eval { require My::Module; };
|
||||
print "Found My::Module" unless $@;
|
||||
|
||||
=for example end
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module allows you to deliberately hide modules from a program
|
||||
even though they are installed. This is mostly useful for testing modules
|
||||
that have a fallback when a certain dependency module is not installed.
|
||||
|
||||
=head2 EXPORT
|
||||
|
||||
None. All magic is done via C<use Test::Without::Module LIST> and
|
||||
C<no Test::Without::Module LIST>.
|
||||
|
||||
=head2 Test::Without::Module::get_forbidden_list
|
||||
|
||||
This function returns a reference to a copy of the current hash of forbidden
|
||||
modules or an empty hash if none are currently forbidden. This is convenient
|
||||
if you are testing and/or debugging this module.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 ONE LINER
|
||||
|
||||
A neat trick for using this module from the command line
|
||||
was mentioned to me by NUFFIN and by Jerrad Pierce:
|
||||
|
||||
perl -MTest::Without::Module=Some::Module -w -Iblib/lib t/SomeModule.t
|
||||
|
||||
That way, you can easily see how your module or test file behaves
|
||||
when a certain module is unavailable.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
There is no lexical scoping
|
||||
|
||||
=back
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Much improvement must be thanked to Aristotle from PerlMonks, he pointed me
|
||||
to a much less convoluted way to fake a module at
|
||||
L<https://perlmonks.org?node=192635>.
|
||||
|
||||
I also discussed with him an even more elegant way of overriding
|
||||
CORE::GLOBAL::require, but the parsing of the overridden subroutine
|
||||
didn't work out the way I wanted it - CORE::require didn't recognize
|
||||
barewords as such anymore.
|
||||
|
||||
NUFFIN and Jerrad Pierce pointed out the convenient
|
||||
use from the command line to interactively watch the
|
||||
behaviour of the test suite and module in absence
|
||||
of a module.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright (c) 2003-2014 Max Maischein, E<lt>corion@cpan.orgE<gt>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is released under the same terms as Perl itself.
|
||||
|
||||
=head1 REPOSITORY
|
||||
|
||||
The public repository of this module is
|
||||
L<https://github.com/Corion/test-without-module>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
The public support forum of this module is
|
||||
L<https://perlmonks.org/>.
|
||||
|
||||
=head1 BUG TRACKER
|
||||
|
||||
Please report bugs in this module via the RT CPAN bug queue at
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Test-Without-Module>
|
||||
or via mail to L<test-without-module-Bugs@rt.cpan.org>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Devel::Hide>, L<Acme::Intraweb>, L<PAR>, L<perlfunc>
|
||||
|
||||
=cut
|
||||
|
||||
__END__
|
||||
233
database/perl/vendor/lib/Test/YAML.pm
vendored
Normal file
233
database/perl/vendor/lib/Test/YAML.pm
vendored
Normal file
@@ -0,0 +1,233 @@
|
||||
package Test::YAML;
|
||||
our $VERSION = '1.07';
|
||||
|
||||
use Test::Base -Base;
|
||||
|
||||
our $YAML = 'YAML';
|
||||
our @EXPORT = qw(
|
||||
no_diff
|
||||
run_yaml_tests
|
||||
run_roundtrip_nyn roundtrip_nyn
|
||||
run_load_passes load_passes
|
||||
dumper Load Dump LoadFile DumpFile
|
||||
XXX
|
||||
);
|
||||
|
||||
delimiters('===', '+++');
|
||||
|
||||
sub Dump () { YAML(Dump => @_) }
|
||||
sub Load () { YAML(Load => @_) }
|
||||
sub DumpFile () { YAML(DumpFile => @_) }
|
||||
sub LoadFile () { YAML(LoadFile => @_) }
|
||||
|
||||
sub YAML () {
|
||||
load_yaml_pm();
|
||||
my $meth = shift;
|
||||
my $code = $YAML->can($meth) or die "$YAML cannot do $meth";
|
||||
goto &$code;
|
||||
}
|
||||
|
||||
sub load_yaml_pm {
|
||||
my $file = "$YAML.pm";
|
||||
$file =~ s{::}{/}g;
|
||||
require $file;
|
||||
}
|
||||
|
||||
sub run_yaml_tests() {
|
||||
run {
|
||||
my $block = shift;
|
||||
&{_get_function($block)}($block) unless
|
||||
_skip_tests_for_now($block) or
|
||||
_skip_yaml_tests($block);
|
||||
};
|
||||
}
|
||||
|
||||
sub run_roundtrip_nyn() {
|
||||
my @options = @_;
|
||||
run {
|
||||
my $block = shift;
|
||||
roundtrip_nyn($block, @options);
|
||||
};
|
||||
}
|
||||
|
||||
sub roundtrip_nyn() {
|
||||
my $block = shift;
|
||||
my $option = shift || '';
|
||||
die "'perl' data section required"
|
||||
unless exists $block->{perl};
|
||||
my @values = eval $block->perl;
|
||||
die "roundtrip_nyn eval perl error: $@" if $@;
|
||||
my $config = $block->config || '';
|
||||
my $result = eval "$config; Dump(\@values)";
|
||||
die "roundtrip_nyn YAML::Dump error: $@" if $@;
|
||||
if (exists $block->{yaml}) {
|
||||
is $result, $block->yaml,
|
||||
$block->description . ' (n->y)';
|
||||
}
|
||||
else {
|
||||
pass $block->description . ' (n->y)';
|
||||
}
|
||||
|
||||
return if exists $block->{no_round_trip} or
|
||||
not exists $block->{yaml};
|
||||
|
||||
if ($option eq 'dumper') {
|
||||
is dumper(Load($block->yaml)), dumper(@values),
|
||||
$block->description . ' (y->n)';
|
||||
}
|
||||
else {
|
||||
is_deeply [Load($block->yaml)], [@values],
|
||||
$block->description . ' (y->n)';
|
||||
}
|
||||
}
|
||||
|
||||
sub count_roundtrip_nyn() {
|
||||
my $block = shift or die "Bad call to count_roundtrip_nyn";
|
||||
return 1 if exists $block->{skip_this_for_now};
|
||||
my $count = 0;
|
||||
$count++ if exists $block->{perl};
|
||||
$count++ unless exists $block->{no_round_trip} or
|
||||
not exists $block->{yaml};
|
||||
die "Invalid test definition" unless $count;
|
||||
return $count;
|
||||
}
|
||||
|
||||
sub run_load_passes() {
|
||||
run {
|
||||
my $block = shift;
|
||||
my $yaml = $block->yaml;
|
||||
eval { YAML(Load => $yaml) };
|
||||
is("$@", "");
|
||||
};
|
||||
}
|
||||
|
||||
sub load_passes() {
|
||||
my $block = shift;
|
||||
my $yaml = $block->yaml;
|
||||
eval { YAML(Load => $yaml) };
|
||||
is "$@", "", $block->description;
|
||||
}
|
||||
|
||||
sub count_load_passes() {1}
|
||||
|
||||
sub dumper() {
|
||||
require Data::Dumper;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$Data::Dumper::Terse = 1;
|
||||
$Data::Dumper::Indent = 1;
|
||||
return Data::Dumper::Dumper(@_);
|
||||
}
|
||||
|
||||
sub _count_tests() {
|
||||
my $block = shift or die "Bad call to _count_tests";
|
||||
no strict 'refs';
|
||||
&{'count_' . _get_function_name($block)}($block);
|
||||
}
|
||||
|
||||
sub _get_function_name() {
|
||||
my $block = shift;
|
||||
return $block->function || 'roundtrip_nyn';
|
||||
}
|
||||
|
||||
sub _get_function() {
|
||||
my $block = shift;
|
||||
no strict 'refs';
|
||||
\ &{_get_function_name($block)};
|
||||
}
|
||||
|
||||
sub _skip_tests_for_now() {
|
||||
my $block = shift;
|
||||
if (exists $block->{skip_this_for_now}) {
|
||||
_skip_test(
|
||||
$block->description,
|
||||
_count_tests($block),
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _skip_yaml_tests() {
|
||||
my $block = shift;
|
||||
if ($block->skip_unless_modules) {
|
||||
my @modules = split /[\s\,]+/, $block->skip_unless_modules;
|
||||
for my $module (@modules) {
|
||||
eval "require $module";
|
||||
if ($@) {
|
||||
_skip_test(
|
||||
"This test requires the '$module' module",
|
||||
_count_tests($block),
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _skip_test() {
|
||||
my ($message, $count) = @_;
|
||||
SKIP: {
|
||||
skip($message, $count);
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------------------
|
||||
package Test::YAML::Filter;
|
||||
|
||||
use Test::Base::Filter ();
|
||||
|
||||
our @ISA = 'Test::Base::Filter';
|
||||
|
||||
sub yaml_dump {
|
||||
Test::YAML::Dump(@_);
|
||||
}
|
||||
|
||||
sub yaml_load {
|
||||
Test::YAML::Load(@_);
|
||||
}
|
||||
|
||||
sub Dump { goto &Test::YAML::Dump }
|
||||
sub Load { goto &Test::YAML::Load }
|
||||
sub DumpFile { goto &Test::YAML::DumpFile }
|
||||
sub LoadFile { goto &Test::YAML::LoadFile }
|
||||
|
||||
sub yaml_load_or_fail {
|
||||
my ($result, $error, $warning) =
|
||||
$self->_yaml_load_result_error_warning(@_);
|
||||
return $error || $result;
|
||||
}
|
||||
|
||||
sub yaml_load_error_or_warning {
|
||||
my ($result, $error, $warning) =
|
||||
$self->_yaml_load_result_error_warning(@_);
|
||||
return $error || $warning || '';
|
||||
}
|
||||
|
||||
sub perl_eval_error_or_warning {
|
||||
my ($result, $error, $warning) =
|
||||
$self->_perl_eval_result_error_warning(@_);
|
||||
return $error || $warning || '';
|
||||
}
|
||||
|
||||
sub _yaml_load_result_error_warning {
|
||||
$self->assert_scalar(@_);
|
||||
my $yaml = shift;
|
||||
my $warning = '';
|
||||
local $SIG{__WARN__} = sub { $warning = join '', @_ };
|
||||
my $result = eval {
|
||||
$self->yaml_load($yaml);
|
||||
};
|
||||
return ($result, $@, $warning);
|
||||
}
|
||||
|
||||
sub _perl_eval_result_error_warning {
|
||||
$self->assert_scalar(@_);
|
||||
my $perl = shift;
|
||||
my $warning = '';
|
||||
local $SIG{__WARN__} = sub { $warning = join '', @_ };
|
||||
my $result = eval $perl;
|
||||
return ($result, $@, $warning);
|
||||
}
|
||||
|
||||
1;
|
||||
40
database/perl/vendor/lib/Test/YAML.pod
vendored
Normal file
40
database/perl/vendor/lib/Test/YAML.pod
vendored
Normal file
@@ -0,0 +1,40 @@
|
||||
=pod
|
||||
|
||||
=for comment
|
||||
DO NOT EDIT. This Pod was generated by Swim v0.1.46.
|
||||
See http://github.com/ingydotnet/swim-pm#readme
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::YAML - Testing Module for YAML Implementations
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This document describes L<Test::YAML> version B<1.07>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::YAML tests => 1;
|
||||
|
||||
pass;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Test::YAML> is a subclass of L<Test::Base> with YAML specific support.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ingy döt Net <ingy@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2001-2018. Ingy döt Net.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
See L<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=cut
|
||||
393
database/perl/vendor/lib/Test/utf8.pm
vendored
Normal file
393
database/perl/vendor/lib/Test/utf8.pm
vendored
Normal file
@@ -0,0 +1,393 @@
|
||||
package Test::utf8;
|
||||
|
||||
use 5.007003;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base qw(Exporter);
|
||||
|
||||
use Encode;
|
||||
use charnames ':full';
|
||||
|
||||
our $VERSION = "1.02";
|
||||
|
||||
our @EXPORT = qw(
|
||||
is_valid_string is_dodgy_utf8 is_sane_utf8
|
||||
is_within_ascii is_within_latin1 is_within_latin_1
|
||||
is_flagged_utf8 isnt_flagged_utf8
|
||||
);
|
||||
|
||||
# A Regexp string to match valid UTF8 bytes
|
||||
# this info comes from page 78 of "The Unicode Standard 4.0"
|
||||
# published by the Unicode Consortium
|
||||
our $valid_utf8_regexp = <<'REGEX' ;
|
||||
[\x{00}-\x{7f}]
|
||||
| [\x{c2}-\x{df}][\x{80}-\x{bf}]
|
||||
| \x{e0} [\x{a0}-\x{bf}][\x{80}-\x{bf}]
|
||||
| [\x{e1}-\x{ec}][\x{80}-\x{bf}][\x{80}-\x{bf}]
|
||||
| \x{ed} [\x{80}-\x{9f}][\x{80}-\x{bf}]
|
||||
| [\x{ee}-\x{ef}][\x{80}-\x{bf}][\x{80}-\x{bf}]
|
||||
| \x{f0} [\x{90}-\x{bf}][\x{80}-\x{bf}]
|
||||
| [\x{f1}-\x{f3}][\x{80}-\x{bf}][\x{80}-\x{bf}][\x{80}-\x{bf}]
|
||||
| \x{f4} [\x{80}-\x{8f}][\x{80}-\x{bf}][\x{80}-\x{bf}]
|
||||
REGEX
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::utf8 - handy utf8 tests
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# check the string is good
|
||||
is_valid_string($string); # check the string is valid
|
||||
is_sane_utf8($string); # check not double encoded
|
||||
|
||||
# check the string has certain attributes
|
||||
is_flagged_utf8($string1); # has utf8 flag set
|
||||
is_within_ascii($string2); # only has ascii chars in it
|
||||
isnt_within_ascii($string3); # has chars outside the ascii range
|
||||
is_within_latin_1($string4); # only has latin-1 chars in it
|
||||
isnt_within_ascii($string5); # has chars outside the latin-1 range
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a collection of tests useful for dealing with utf8 strings in
|
||||
Perl.
|
||||
|
||||
This module has two types of tests: The validity tests check if a string is
|
||||
valid and not corrupt, whereas the characteristics tests will check that string
|
||||
has a given set of characteristics.
|
||||
|
||||
=head2 Validity Tests
|
||||
|
||||
=over
|
||||
|
||||
=item is_valid_string($string, $testname)
|
||||
|
||||
Checks if the string is "valid", i.e. this passes and returns true unless
|
||||
the internal utf8 flag hasn't been set on scalar that isn't made up of a valid
|
||||
utf-8 byte sequence.
|
||||
|
||||
This should I<never> happen and, in theory, this test should always pass. Unless
|
||||
you (or a module you use) goes monkeying around inside a scalar using Encode's
|
||||
private functions or XS code you shouldn't ever end up in a situation where
|
||||
you've got a corrupt scalar. But if you do, and you do, then this function
|
||||
should help you detect the problem.
|
||||
|
||||
To be clear, here's an example of the error case this can detect:
|
||||
|
||||
my $mark = "Mark";
|
||||
my $leon = "L\x{e9}on";
|
||||
is_valid_string($mark); # passes, not utf-8
|
||||
is_valid_string($leon); # passes, not utf-8
|
||||
|
||||
my $iloveny = "I \x{2665} NY";
|
||||
is_valid_string($iloveny); # passes, proper utf-8
|
||||
|
||||
my $acme = "L\x{c3}\x{a9}on";
|
||||
Encode::_utf8_on($acme); # (please don't do things like this)
|
||||
is_valid_string($acme); # passes, proper utf-8 byte sequence upgraded
|
||||
|
||||
Encode::_utf8_on($leon); # (this is why you don't do things like this)
|
||||
is_valid_string($leon); # fails! the byte \x{e9} isn't valid utf-8
|
||||
|
||||
=cut
|
||||
|
||||
sub is_valid_string($;$)
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "valid string test";
|
||||
|
||||
# check we're a utf8 string - if not, we pass.
|
||||
unless (Encode::is_utf8($string))
|
||||
{ return _pass($name) }
|
||||
|
||||
# work out at what byte (if any) we have an invalid byte sequence
|
||||
# and return the correct test result
|
||||
my $pos = _invalid_sequence_at_byte($string);
|
||||
if (_ok(!defined($pos), $name)) { return 1 }
|
||||
_diag("malformed byte sequence starting at byte $pos");
|
||||
return;
|
||||
}
|
||||
|
||||
sub _invalid_sequence_at_byte($)
|
||||
{
|
||||
my $string = shift;
|
||||
|
||||
# examine the bytes that make up the string (not the chars)
|
||||
# by turning off the utf8 flag (no, use bytes doesn't
|
||||
# work, we're dealing with a regexp)
|
||||
Encode::_utf8_off($string); ## no critic (ProtectPrivateSubs)
|
||||
|
||||
# work out the index of the first non matching byte
|
||||
my $result = $string =~ m/^($valid_utf8_regexp)*/ogx;
|
||||
|
||||
# if we matched all the string return the empty list
|
||||
my $pos = pos $string || 0;
|
||||
return if $pos == length($string);
|
||||
|
||||
# otherwise return the position we found
|
||||
return $pos
|
||||
}
|
||||
|
||||
=item is_sane_utf8($string, $name)
|
||||
|
||||
This test fails if the string contains something that looks like it
|
||||
might be dodgy utf8, i.e. containing something that looks like the
|
||||
multi-byte sequence for a latin-1 character but perl hasn't been
|
||||
instructed to treat as such. Strings that are not utf8 always
|
||||
automatically pass.
|
||||
|
||||
Some examples may help:
|
||||
|
||||
# This will pass as it's a normal latin-1 string
|
||||
is_sane_utf8("Hello L\x{e9}eon");
|
||||
|
||||
# this will fail because the \x{c3}\x{a9} looks like the
|
||||
# utf8 byte sequence for e-acute
|
||||
my $string = "Hello L\x{c3}\x{a9}on";
|
||||
is_sane_utf8($string);
|
||||
|
||||
# this will pass because the utf8 is correctly interpreted as utf8
|
||||
Encode::_utf8_on($string)
|
||||
is_sane_utf8($string);
|
||||
|
||||
Obviously this isn't a hundred percent reliable. The edge case where
|
||||
this will fail is where you have C<\x{c2}> (which is "LATIN CAPITAL
|
||||
LETTER WITH CIRCUMFLEX") or C<\x{c3}> (which is "LATIN CAPITAL LETTER
|
||||
WITH TILDE") followed by one of the latin-1 punctuation symbols.
|
||||
|
||||
# a capital letter A with tilde surrounded by smart quotes
|
||||
# this will fail because it'll see the "\x{c2}\x{94}" and think
|
||||
# it's actually the utf8 sequence for the end smart quote
|
||||
is_sane_utf8("\x{93}\x{c2}\x{94}");
|
||||
|
||||
However, since this hardly comes up this test is reasonably reliable
|
||||
in most cases. Still, care should be applied in cases where dynamic
|
||||
data is placed next to latin-1 punctuation to avoid false negatives.
|
||||
|
||||
There exists two situations to cause this test to fail; The string
|
||||
contains utf8 byte sequences and the string hasn't been flagged as
|
||||
utf8 (this normally means that you got it from an external source like
|
||||
a C library; When Perl needs to store a string internally as utf8 it
|
||||
does it's own encoding and flagging transparently) or a utf8 flagged
|
||||
string contains byte sequences that when translated to characters
|
||||
themselves look like a utf8 byte sequence. The test diagnostics tells
|
||||
you which is the case.
|
||||
|
||||
=cut
|
||||
|
||||
# build my regular expression out of the latin-1 bytes
|
||||
# NOTE: This won't work if our locale is nonstandard will it?
|
||||
my $re_bit = join "|", map { Encode::encode("utf8",chr($_)) } (127..255);
|
||||
|
||||
sub is_sane_utf8($;$)
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "sane utf8";
|
||||
|
||||
# regexp in scalar context with 'g', meaning this loop will run for
|
||||
# each match. Should only have to run it once, but will redo if
|
||||
# the failing case turns out to be allowed in %allowed.
|
||||
while ($string =~ /($re_bit)/o)
|
||||
{
|
||||
# work out what the double encoded string was
|
||||
my $bytes = $1;
|
||||
|
||||
my $index = $+[0] - length($bytes);
|
||||
my $codes = join '', map { sprintf '<%00x>', ord($_) } split //, $bytes;
|
||||
|
||||
# what character does that represent?
|
||||
my $char = Encode::decode("utf8",$bytes);
|
||||
my $ord = ord($char);
|
||||
my $hex = sprintf '%00x', $ord;
|
||||
$char = charnames::viacode($ord);
|
||||
|
||||
# print out diagnostic messages
|
||||
_fail($name);
|
||||
_diag(qq{Found dodgy chars "$codes" at char $index\n});
|
||||
if (Encode::is_utf8($string))
|
||||
{ _diag("Chars in utf8 string look like utf8 byte sequence.") }
|
||||
else
|
||||
{ _diag("String not flagged as utf8...was it meant to be?\n") }
|
||||
_diag("Probably originally a $char char - codepoint $ord (dec),"
|
||||
." $hex (hex)\n");
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
# got this far, must have passed.
|
||||
_ok(1,$name);
|
||||
return 1;
|
||||
}
|
||||
|
||||
# historic name of method; deprecated
|
||||
sub is_dodgy_utf8 { goto &is_sane_utf8 }
|
||||
|
||||
=back
|
||||
|
||||
=head2 String Characteristic Tests
|
||||
|
||||
These routines allow you to check the range of characters in a string.
|
||||
Note that these routines are blind to the actual encoding perl
|
||||
internally uses to store the characters, they just check if the
|
||||
string contains only characters that can be represented in the named
|
||||
encoding:
|
||||
|
||||
=over
|
||||
|
||||
=item is_within_ascii
|
||||
|
||||
Tests that a string only contains characters that are in the ASCII
|
||||
character set.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_within_ascii($;$)
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "within ascii";
|
||||
|
||||
# look for anything that isn't ascii or pass
|
||||
$string =~ /([^\x{00}-\x{7f}])/ or return _pass($name);
|
||||
|
||||
# explain why we failed
|
||||
my $dec = ord($1);
|
||||
my $hex = sprintf '%02x', $dec;
|
||||
|
||||
_fail($name);
|
||||
_diag("Char $+[0] not ASCII (it's $dec dec / $hex hex)");
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
=item is_within_latin_1
|
||||
|
||||
Tests that a string only contains characters that are in latin-1.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_within_latin_1($;$)
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "within latin-1";
|
||||
|
||||
# look for anything that isn't ascii or pass
|
||||
$string =~ /([^\x{00}-\x{ff}])/ or return _pass($name);
|
||||
|
||||
# explain why we failed
|
||||
my $dec = ord($1);
|
||||
my $hex = sprintf '%x', $dec;
|
||||
|
||||
_fail($name);
|
||||
_diag("Char $+[0] not Latin-1 (it's $dec dec / $hex hex)");
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub is_within_latin1 { goto &is_within_latin_1 }
|
||||
|
||||
=back
|
||||
|
||||
Simply check if a scalar is or isn't flagged as utf8 by perl's
|
||||
internals:
|
||||
|
||||
=over
|
||||
|
||||
=item is_flagged_utf8($string, $name)
|
||||
|
||||
Passes if the string is flagged by perl's internals as utf8, fails if
|
||||
it's not.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_flagged_utf8
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "flagged as utf8";
|
||||
return _ok(Encode::is_utf8($string),$name);
|
||||
}
|
||||
|
||||
=item isnt_flagged_utf8($string,$name)
|
||||
|
||||
The opposite of C<is_flagged_utf8>, passes if and only if the string
|
||||
isn't flagged as utf8 by perl's internals.
|
||||
|
||||
Note: you can refer to this function as C<isn't_flagged_utf8> if you
|
||||
really want to.
|
||||
|
||||
=cut
|
||||
|
||||
sub isnt_flagged_utf8($;$)
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "not flagged as utf8";
|
||||
return _ok(!Encode::is_utf8($string), $name);
|
||||
}
|
||||
|
||||
sub isn::t_flagged_utf8($;$)
|
||||
{
|
||||
my $string = shift;
|
||||
my $name = shift || "not flagged as utf8";
|
||||
return _ok(!Encode::is_utf8($string), $name);
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Written by Mark Fowler B<mark@twoshortplanks.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright Mark Fowler 2004,2012. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it
|
||||
and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
None known. Please report any to me via the CPAN RT system. See
|
||||
http://rt.cpan.org/ for more details.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test::DoubleEncodedEntities> for testing for double encoded HTML
|
||||
entities.
|
||||
|
||||
=cut
|
||||
|
||||
##########
|
||||
|
||||
# shortcuts for Test::Builder.
|
||||
|
||||
use Test::Builder;
|
||||
my $tester = Test::Builder->new();
|
||||
|
||||
sub _ok
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
return $tester->ok(@_)
|
||||
}
|
||||
sub _diag
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
$tester->diag(@_);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _fail
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
return _ok(0,@_)
|
||||
}
|
||||
|
||||
sub _pass
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
return _ok(1,@_)
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user