Imported Upstream version 0.18
This commit is contained in:
Mario Fetka
653
inc/Test/Base.pm
Normal file
653
inc/Test/Base.pm
Normal file
@@ -0,0 +1,653 @@
|
||||
#line 1
|
||||
# TODO:
|
||||
#
|
||||
package Test::Base;
|
||||
use 5.006001;
|
||||
use Spiffy 0.30 -Base;
|
||||
use Spiffy ':XXX';
|
||||
our $VERSION = '0.55';
|
||||
|
||||
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
|
||||
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;
|
||||
}
|
||||
|
||||
sub is($$;$) {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my ($actual, $expected, $name) = @_;
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
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 . "\n" . 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 @_ 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(@_);
|
||||
$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 _pre_eval {
|
||||
my $spec = shift;
|
||||
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;
|
||||
$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 {
|
||||
$spec = do {
|
||||
package main;
|
||||
no warnings 'once';
|
||||
<DATA>;
|
||||
};
|
||||
}
|
||||
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 $_ = join '', @value;
|
||||
my $old = $_;
|
||||
@value = &$function(@value);
|
||||
if (not(@value) or
|
||||
@value == 1 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 );
|
||||
}
|
||||
|
||||
__DATA__
|
||||
|
||||
=encoding utf8
|
||||
|
||||
#line 1330
|
||||
344
inc/Test/Base/Filter.pm
Normal file
344
inc/Test/Base/Filter.pm
Normal file
@@ -0,0 +1,344 @@
|
||||
#line 1
|
||||
#. TODO:
|
||||
#.
|
||||
|
||||
#===============================================================================
|
||||
# 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";
|
||||
}
|
||||
|
||||
__DATA__
|
||||
|
||||
#line 639
|
||||
1175
inc/Test/Builder.pm
Normal file
1175
inc/Test/Builder.pm
Normal file
File diff suppressed because it is too large
Load Diff
82
inc/Test/Builder/Module.pm
Normal file
82
inc/Test/Builder/Module.pm
Normal file
@@ -0,0 +1,82 @@
|
||||
#line 1
|
||||
package Test::Builder::Module;
|
||||
|
||||
use Test::Builder;
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
$VERSION = '0.72';
|
||||
|
||||
use strict;
|
||||
|
||||
# 5.004's Exporter doesn't have export_to_level.
|
||||
my $_export_to_level = sub {
|
||||
my $pkg = shift;
|
||||
my $level = shift;
|
||||
(undef) = shift; # redundant arg
|
||||
my $callpkg = caller($level);
|
||||
$pkg->export($callpkg, @_);
|
||||
};
|
||||
|
||||
|
||||
#line 82
|
||||
|
||||
sub import {
|
||||
my($class) = shift;
|
||||
|
||||
my $test = $class->builder;
|
||||
|
||||
my $caller = caller;
|
||||
|
||||
$test->exported_to($caller);
|
||||
|
||||
$class->import_extra(\@_);
|
||||
my(@imports) = $class->_strip_imports(\@_);
|
||||
|
||||
$test->plan(@_);
|
||||
|
||||
$class->$_export_to_level(1, $class, @imports);
|
||||
}
|
||||
|
||||
|
||||
sub _strip_imports {
|
||||
my $class = shift;
|
||||
my $list = shift;
|
||||
|
||||
my @imports = ();
|
||||
my @other = ();
|
||||
my $idx = 0;
|
||||
while( $idx <= $#{$list} ) {
|
||||
my $item = $list->[$idx];
|
||||
|
||||
if( defined $item and $item eq 'import' ) {
|
||||
push @imports, @{$list->[$idx+1]};
|
||||
$idx++;
|
||||
}
|
||||
else {
|
||||
push @other, $item;
|
||||
}
|
||||
|
||||
$idx++;
|
||||
}
|
||||
|
||||
@$list = @other;
|
||||
|
||||
return @imports;
|
||||
}
|
||||
|
||||
|
||||
#line 144
|
||||
|
||||
sub import_extra {}
|
||||
|
||||
|
||||
#line 175
|
||||
|
||||
sub builder {
|
||||
return Test::Builder->new;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
672
inc/Test/More.pm
Normal file
672
inc/Test/More.pm
Normal file
@@ -0,0 +1,672 @@
|
||||
#line 1
|
||||
package Test::More;
|
||||
|
||||
use 5.004;
|
||||
|
||||
use strict;
|
||||
|
||||
|
||||
# Can't use Carp because it might cause use_ok() to accidentally succeed
|
||||
# even though the module being used forgot to use Carp. Yes, this
|
||||
# actually happened.
|
||||
sub _carp {
|
||||
my($file, $line) = (caller(1))[1,2];
|
||||
warn @_, " at $file line $line\n";
|
||||
}
|
||||
|
||||
|
||||
|
||||
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
|
||||
$VERSION = '0.72';
|
||||
$VERSION = eval $VERSION; # make the alpha version come out as a number
|
||||
|
||||
use Test::Builder::Module;
|
||||
@ISA = qw(Test::Builder::Module);
|
||||
@EXPORT = qw(ok use_ok require_ok
|
||||
is isnt like unlike is_deeply
|
||||
cmp_ok
|
||||
skip todo todo_skip
|
||||
pass fail
|
||||
eq_array eq_hash eq_set
|
||||
$TODO
|
||||
plan
|
||||
can_ok isa_ok
|
||||
diag
|
||||
BAIL_OUT
|
||||
);
|
||||
|
||||
|
||||
#line 157
|
||||
|
||||
sub plan {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->plan(@_);
|
||||
}
|
||||
|
||||
|
||||
# This implements "use Test::More 'no_diag'" but the behavior is
|
||||
# deprecated.
|
||||
sub import_extra {
|
||||
my $class = shift;
|
||||
my $list = shift;
|
||||
|
||||
my @other = ();
|
||||
my $idx = 0;
|
||||
while( $idx <= $#{$list} ) {
|
||||
my $item = $list->[$idx];
|
||||
|
||||
if( defined $item and $item eq 'no_diag' ) {
|
||||
$class->builder->no_diag(1);
|
||||
}
|
||||
else {
|
||||
push @other, $item;
|
||||
}
|
||||
|
||||
$idx++;
|
||||
}
|
||||
|
||||
@$list = @other;
|
||||
}
|
||||
|
||||
|
||||
#line 257
|
||||
|
||||
sub ok ($;$) {
|
||||
my($test, $name) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->ok($test, $name);
|
||||
}
|
||||
|
||||
#line 324
|
||||
|
||||
sub is ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->is_eq(@_);
|
||||
}
|
||||
|
||||
sub isnt ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->isnt_eq(@_);
|
||||
}
|
||||
|
||||
*isn't = \&isnt;
|
||||
|
||||
|
||||
#line 369
|
||||
|
||||
sub like ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->like(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 385
|
||||
|
||||
sub unlike ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->unlike(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 425
|
||||
|
||||
sub cmp_ok($$$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->cmp_ok(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 461
|
||||
|
||||
sub can_ok ($@) {
|
||||
my($proto, @methods) = @_;
|
||||
my $class = ref $proto || $proto;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( $class ) {
|
||||
my $ok = $tb->ok( 0, "->can(...)" );
|
||||
$tb->diag(' can_ok() called with empty class or reference');
|
||||
return $ok;
|
||||
}
|
||||
|
||||
unless( @methods ) {
|
||||
my $ok = $tb->ok( 0, "$class->can(...)" );
|
||||
$tb->diag(' can_ok() called with no methods');
|
||||
return $ok;
|
||||
}
|
||||
|
||||
my @nok = ();
|
||||
foreach my $method (@methods) {
|
||||
$tb->_try(sub { $proto->can($method) }) or push @nok, $method;
|
||||
}
|
||||
|
||||
my $name;
|
||||
$name = @methods == 1 ? "$class->can('$methods[0]')"
|
||||
: "$class->can(...)";
|
||||
|
||||
my $ok = $tb->ok( !@nok, $name );
|
||||
|
||||
$tb->diag(map " $class->can('$_') failed\n", @nok);
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#line 523
|
||||
|
||||
sub isa_ok ($$;$) {
|
||||
my($object, $class, $obj_name) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my $diag;
|
||||
$obj_name = 'The object' unless defined $obj_name;
|
||||
my $name = "$obj_name isa $class";
|
||||
if( !defined $object ) {
|
||||
$diag = "$obj_name isn't defined";
|
||||
}
|
||||
elsif( !ref $object ) {
|
||||
$diag = "$obj_name isn't a reference";
|
||||
}
|
||||
else {
|
||||
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
|
||||
my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
|
||||
if( $error ) {
|
||||
if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
|
||||
# Its an unblessed reference
|
||||
if( !UNIVERSAL::isa($object, $class) ) {
|
||||
my $ref = ref $object;
|
||||
$diag = "$obj_name isn't a '$class' it's a '$ref'";
|
||||
}
|
||||
} else {
|
||||
die <<WHOA;
|
||||
WHOA! I tried to call ->isa on your object and got some weird error.
|
||||
Here's the error.
|
||||
$error
|
||||
WHOA
|
||||
}
|
||||
}
|
||||
elsif( !$rslt ) {
|
||||
my $ref = ref $object;
|
||||
$diag = "$obj_name isn't a '$class' it's a '$ref'";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
my $ok;
|
||||
if( $diag ) {
|
||||
$ok = $tb->ok( 0, $name );
|
||||
$tb->diag(" $diag\n");
|
||||
}
|
||||
else {
|
||||
$ok = $tb->ok( 1, $name );
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
#line 592
|
||||
|
||||
sub pass (;$) {
|
||||
my $tb = Test::More->builder;
|
||||
$tb->ok(1, @_);
|
||||
}
|
||||
|
||||
sub fail (;$) {
|
||||
my $tb = Test::More->builder;
|
||||
$tb->ok(0, @_);
|
||||
}
|
||||
|
||||
#line 653
|
||||
|
||||
sub use_ok ($;@) {
|
||||
my($module, @imports) = @_;
|
||||
@imports = () unless @imports;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my($pack,$filename,$line) = caller;
|
||||
|
||||
local($@,$!,$SIG{__DIE__}); # isolate eval
|
||||
|
||||
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
|
||||
# probably a version check. Perl needs to see the bare number
|
||||
# for it to work with non-Exporter based modules.
|
||||
eval <<USE;
|
||||
package $pack;
|
||||
use $module $imports[0];
|
||||
USE
|
||||
}
|
||||
else {
|
||||
eval <<USE;
|
||||
package $pack;
|
||||
use $module \@imports;
|
||||
USE
|
||||
}
|
||||
|
||||
my $ok = $tb->ok( !$@, "use $module;" );
|
||||
|
||||
unless( $ok ) {
|
||||
chomp $@;
|
||||
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
|
||||
{BEGIN failed--compilation aborted at $filename line $line.}m;
|
||||
$tb->diag(<<DIAGNOSTIC);
|
||||
Tried to use '$module'.
|
||||
Error: $@
|
||||
DIAGNOSTIC
|
||||
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#line 702
|
||||
|
||||
sub require_ok ($) {
|
||||
my($module) = shift;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my $pack = caller;
|
||||
|
||||
# Try to deterine if we've been given a module name or file.
|
||||
# Module names must be barewords, files not.
|
||||
$module = qq['$module'] unless _is_module_name($module);
|
||||
|
||||
local($!, $@, $SIG{__DIE__}); # isolate eval
|
||||
local $SIG{__DIE__};
|
||||
eval <<REQUIRE;
|
||||
package $pack;
|
||||
require $module;
|
||||
REQUIRE
|
||||
|
||||
my $ok = $tb->ok( !$@, "require $module;" );
|
||||
|
||||
unless( $ok ) {
|
||||
chomp $@;
|
||||
$tb->diag(<<DIAGNOSTIC);
|
||||
Tried to require '$module'.
|
||||
Error: $@
|
||||
DIAGNOSTIC
|
||||
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub _is_module_name {
|
||||
my $module = shift;
|
||||
|
||||
# Module names start with a letter.
|
||||
# End with an alphanumeric.
|
||||
# The rest is an alphanumeric or ::
|
||||
$module =~ s/\b::\b//g;
|
||||
$module =~ /^[a-zA-Z]\w*$/;
|
||||
}
|
||||
|
||||
#line 779
|
||||
|
||||
use vars qw(@Data_Stack %Refs_Seen);
|
||||
my $DNE = bless [], 'Does::Not::Exist';
|
||||
|
||||
sub _dne {
|
||||
ref $_[0] eq ref $DNE;
|
||||
}
|
||||
|
||||
|
||||
sub is_deeply {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( @_ == 2 or @_ == 3 ) {
|
||||
my $msg = <<WARNING;
|
||||
is_deeply() takes two or three args, you gave %d.
|
||||
This usually means you passed an array or hash instead
|
||||
of a reference to it
|
||||
WARNING
|
||||
chop $msg; # clip off newline so carp() will put in line/file
|
||||
|
||||
_carp sprintf $msg, scalar @_;
|
||||
|
||||
return $tb->ok(0);
|
||||
}
|
||||
|
||||
my($got, $expected, $name) = @_;
|
||||
|
||||
$tb->_unoverload_str(\$expected, \$got);
|
||||
|
||||
my $ok;
|
||||
if( !ref $got and !ref $expected ) { # neither is a reference
|
||||
$ok = $tb->is_eq($got, $expected, $name);
|
||||
}
|
||||
elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
|
||||
$ok = $tb->ok(0, $name);
|
||||
$tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
|
||||
}
|
||||
else { # both references
|
||||
local @Data_Stack = ();
|
||||
if( _deep_check($got, $expected) ) {
|
||||
$ok = $tb->ok(1, $name);
|
||||
}
|
||||
else {
|
||||
$ok = $tb->ok(0, $name);
|
||||
$tb->diag(_format_stack(@Data_Stack));
|
||||
}
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub _format_stack {
|
||||
my(@Stack) = @_;
|
||||
|
||||
my $var = '$FOO';
|
||||
my $did_arrow = 0;
|
||||
foreach my $entry (@Stack) {
|
||||
my $type = $entry->{type} || '';
|
||||
my $idx = $entry->{'idx'};
|
||||
if( $type eq 'HASH' ) {
|
||||
$var .= "->" unless $did_arrow++;
|
||||
$var .= "{$idx}";
|
||||
}
|
||||
elsif( $type eq 'ARRAY' ) {
|
||||
$var .= "->" unless $did_arrow++;
|
||||
$var .= "[$idx]";
|
||||
}
|
||||
elsif( $type eq 'REF' ) {
|
||||
$var = "\${$var}";
|
||||
}
|
||||
}
|
||||
|
||||
my @vals = @{$Stack[-1]{vals}}[0,1];
|
||||
my @vars = ();
|
||||
($vars[0] = $var) =~ s/\$FOO/ \$got/;
|
||||
($vars[1] = $var) =~ s/\$FOO/\$expected/;
|
||||
|
||||
my $out = "Structures begin differing at:\n";
|
||||
foreach my $idx (0..$#vals) {
|
||||
my $val = $vals[$idx];
|
||||
$vals[$idx] = !defined $val ? 'undef' :
|
||||
_dne($val) ? "Does not exist" :
|
||||
ref $val ? "$val" :
|
||||
"'$val'";
|
||||
}
|
||||
|
||||
$out .= "$vars[0] = $vals[0]\n";
|
||||
$out .= "$vars[1] = $vals[1]\n";
|
||||
|
||||
$out =~ s/^/ /msg;
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
sub _type {
|
||||
my $thing = shift;
|
||||
|
||||
return '' if !ref $thing;
|
||||
|
||||
for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
|
||||
return $type if UNIVERSAL::isa($thing, $type);
|
||||
}
|
||||
|
||||
return '';
|
||||
}
|
||||
|
||||
#line 925
|
||||
|
||||
sub diag {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->diag(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 994
|
||||
|
||||
#'#
|
||||
sub skip {
|
||||
my($why, $how_many) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( defined $how_many ) {
|
||||
# $how_many can only be avoided when no_plan is in use.
|
||||
_carp "skip() needs to know \$how_many tests are in the block"
|
||||
unless $tb->has_plan eq 'no_plan';
|
||||
$how_many = 1;
|
||||
}
|
||||
|
||||
if( defined $how_many and $how_many =~ /\D/ ) {
|
||||
_carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
|
||||
$how_many = 1;
|
||||
}
|
||||
|
||||
for( 1..$how_many ) {
|
||||
$tb->skip($why);
|
||||
}
|
||||
|
||||
local $^W = 0;
|
||||
last SKIP;
|
||||
}
|
||||
|
||||
|
||||
#line 1081
|
||||
|
||||
sub todo_skip {
|
||||
my($why, $how_many) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( defined $how_many ) {
|
||||
# $how_many can only be avoided when no_plan is in use.
|
||||
_carp "todo_skip() needs to know \$how_many tests are in the block"
|
||||
unless $tb->has_plan eq 'no_plan';
|
||||
$how_many = 1;
|
||||
}
|
||||
|
||||
for( 1..$how_many ) {
|
||||
$tb->todo_skip($why);
|
||||
}
|
||||
|
||||
local $^W = 0;
|
||||
last TODO;
|
||||
}
|
||||
|
||||
#line 1134
|
||||
|
||||
sub BAIL_OUT {
|
||||
my $reason = shift;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->BAIL_OUT($reason);
|
||||
}
|
||||
|
||||
#line 1173
|
||||
|
||||
#'#
|
||||
sub eq_array {
|
||||
local @Data_Stack;
|
||||
_deep_check(@_);
|
||||
}
|
||||
|
||||
sub _eq_array {
|
||||
my($a1, $a2) = @_;
|
||||
|
||||
if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
|
||||
warn "eq_array passed a non-array ref";
|
||||
return 0;
|
||||
}
|
||||
|
||||
return 1 if $a1 eq $a2;
|
||||
|
||||
my $ok = 1;
|
||||
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
|
||||
for (0..$max) {
|
||||
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
|
||||
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
|
||||
|
||||
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
|
||||
$ok = _deep_check($e1,$e2);
|
||||
pop @Data_Stack if $ok;
|
||||
|
||||
last unless $ok;
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub _deep_check {
|
||||
my($e1, $e2) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my $ok = 0;
|
||||
|
||||
# Effectively turn %Refs_Seen into a stack. This avoids picking up
|
||||
# the same referenced used twice (such as [\$a, \$a]) to be considered
|
||||
# circular.
|
||||
local %Refs_Seen = %Refs_Seen;
|
||||
|
||||
{
|
||||
# Quiet uninitialized value warnings when comparing undefs.
|
||||
local $^W = 0;
|
||||
|
||||
$tb->_unoverload_str(\$e1, \$e2);
|
||||
|
||||
# Either they're both references or both not.
|
||||
my $same_ref = !(!ref $e1 xor !ref $e2);
|
||||
my $not_ref = (!ref $e1 and !ref $e2);
|
||||
|
||||
if( defined $e1 xor defined $e2 ) {
|
||||
$ok = 0;
|
||||
}
|
||||
elsif ( _dne($e1) xor _dne($e2) ) {
|
||||
$ok = 0;
|
||||
}
|
||||
elsif ( $same_ref and ($e1 eq $e2) ) {
|
||||
$ok = 1;
|
||||
}
|
||||
elsif ( $not_ref ) {
|
||||
push @Data_Stack, { type => '', vals => [$e1, $e2] };
|
||||
$ok = 0;
|
||||
}
|
||||
else {
|
||||
if( $Refs_Seen{$e1} ) {
|
||||
return $Refs_Seen{$e1} eq $e2;
|
||||
}
|
||||
else {
|
||||
$Refs_Seen{$e1} = "$e2";
|
||||
}
|
||||
|
||||
my $type = _type($e1);
|
||||
$type = 'DIFFERENT' unless _type($e2) eq $type;
|
||||
|
||||
if( $type eq 'DIFFERENT' ) {
|
||||
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
||||
$ok = 0;
|
||||
}
|
||||
elsif( $type eq 'ARRAY' ) {
|
||||
$ok = _eq_array($e1, $e2);
|
||||
}
|
||||
elsif( $type eq 'HASH' ) {
|
||||
$ok = _eq_hash($e1, $e2);
|
||||
}
|
||||
elsif( $type eq 'REF' ) {
|
||||
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
||||
$ok = _deep_check($$e1, $$e2);
|
||||
pop @Data_Stack if $ok;
|
||||
}
|
||||
elsif( $type eq 'SCALAR' ) {
|
||||
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
|
||||
$ok = _deep_check($$e1, $$e2);
|
||||
pop @Data_Stack if $ok;
|
||||
}
|
||||
elsif( $type ) {
|
||||
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
||||
$ok = 0;
|
||||
}
|
||||
else {
|
||||
_whoa(1, "No type in _deep_check");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub _whoa {
|
||||
my($check, $desc) = @_;
|
||||
if( $check ) {
|
||||
die <<WHOA;
|
||||
WHOA! $desc
|
||||
This should never happen! Please contact the author immediately!
|
||||
WHOA
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#line 1304
|
||||
|
||||
sub eq_hash {
|
||||
local @Data_Stack;
|
||||
return _deep_check(@_);
|
||||
}
|
||||
|
||||
sub _eq_hash {
|
||||
my($a1, $a2) = @_;
|
||||
|
||||
if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
|
||||
warn "eq_hash passed a non-hash ref";
|
||||
return 0;
|
||||
}
|
||||
|
||||
return 1 if $a1 eq $a2;
|
||||
|
||||
my $ok = 1;
|
||||
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
|
||||
foreach my $k (keys %$bigger) {
|
||||
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
|
||||
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
|
||||
|
||||
push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
|
||||
$ok = _deep_check($e1, $e2);
|
||||
pop @Data_Stack if $ok;
|
||||
|
||||
last unless $ok;
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#line 1361
|
||||
|
||||
sub eq_set {
|
||||
my($a1, $a2) = @_;
|
||||
return 0 unless @$a1 == @$a2;
|
||||
|
||||
# There's faster ways to do this, but this is easiest.
|
||||
local $^W = 0;
|
||||
|
||||
# It really doesn't matter how we sort them, as long as both arrays are
|
||||
# sorted with the same algorithm.
|
||||
#
|
||||
# Ensure that references are not accidentally treated the same as a
|
||||
# string containing the reference.
|
||||
#
|
||||
# Have to inline the sort routine due to a threading/sort bug.
|
||||
# See [rt.cpan.org 6782]
|
||||
#
|
||||
# I don't know how references would be sorted so we just don't sort
|
||||
# them. This means eq_set doesn't really work with refs.
|
||||
return eq_array(
|
||||
[grep(ref, @$a1), sort( grep(!ref, @$a1) )],
|
||||
[grep(ref, @$a2), sort( grep(!ref, @$a2) )],
|
||||
);
|
||||
}
|
||||
|
||||
#line 1551
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user