view release on metacpan or  search on metacpan

inc/Test/Base.pm  view on Meta::CPAN

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}) {

inc/Test/Base.pm  view on Meta::CPAN

            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;