view release on metacpan or  search on metacpan

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

#line 1
# TODO:
#
package Test::Base;
use 5.006001;
use Spiffy 0.30 -Base;
use Spiffy ':XXX';
our $VERSION = '0.52';

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

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

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

        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) {
                $_ = join '', @value;
                @value = &$function(@value);
                if (not(@value) or 
                    @value == 1 and $value[0] =~ /\A(\d+|)\z/