view release on metacpan or  search on metacpan

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

}

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