File Coverage

blib/lib/Test/Chunks.pm

Criterion	Covered	Total	%
statement	426	457	93.2
branch	126	154	81.8
condition	44	60	73.3
subroutine	75	79	94.9
pod	15	22	68.1
total	686	772	88.8

package Test::Chunks;
use Spiffy 0.24 -Base;
use Spiffy ':XXX';
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
        $TODO
    );
}
use Test::More import => \@test_more_exports;
use Carp;

our @EXPORT = (@test_more_exports, qw(
    is

    chunks next_chunk
    delimiters spec_file spec_string
    filters filters_delay filter_arguments
    run run_is run_is_deeply run_like run_unlike
    WWW XXX YYY ZZZ
    tie_output

    find_my_self default_object

    croak carp cluck confess
));

our $VERSION = '0.39';

field '_spec_file';
field '_spec_string';
field _filters => [qw(norm trim)];
field _filters_map => {};
field spec =>
      -init => '$self->_spec_init';
field chunk_list =>
      -init => '$self->_chunk_list_init';
field _next_list => [];
field chunk_delim =>
      -init => '$self->chunk_delim_default';
field data_delim =>
      -init => '$self->data_delim_default';
field _filters_delay => 0;

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

sub import() {
    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);
    }

    if (@_ > 1 and not grep /^-base$/i, @_) {
        my @args = @_;
        shift @args;
        Test::More->import(import => \@test_more_exports, @args);
    }

    _strict_warnings();
    goto &Spiffy::import;
}

sub chunk_class  { $self->find_class('Chunk') }
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');
    die "Can't find a class for $suffix";
}

sub check_late {
    if ($self->{chunk_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 chunks() {
    (my ($self), @_) = find_my_self(@_);

    croak "Invalid arguments passed to 'chunks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to chunks()", shift(@_))
      if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;

    my $chunks = $self->chunk_list;

    my $section_name = shift || '';
    my @chunks = $section_name
    ? (grep { exists $_->{$section_name} } @$chunks)
    : (@$chunks);

    return scalar(@chunks) unless wantarray;

    return (@chunks) if $self->_filters_delay;

    for my $chunk (@chunks) {
        $chunk->run_filters
          unless $chunk->is_filtered;
    }

    return (@chunks);
}

sub next_chunk() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->chunk_list}, undef];
        $self->_next_list($list);
    }
    my $chunk = shift @$list;
    if (defined $chunk and not $chunk->is_filtered) {
        $chunk->run_filters;
    }
    return $chunk;
}

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 ($chunk_delimiter, $data_delimiter) = @_;
    $chunk_delimiter ||= $self->chunk_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->chunk_delim($chunk_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::Chunks::Filter::arguments;
}

sub have_text_diff {
    eval { require Text::Diff; 1 };
}

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
         $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(\$actual, \$expected);
    }
}

sub run(&) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $chunk (@{$self->chunk_list}) {
        $chunk->run_filters unless $chunk->is_filtered;
        &{$callback}($chunk);
    }
}

sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    my ($x, $y) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $chunk (@{$self->chunk_list}) {
        next unless exists($chunk->{$x}) and exists($chunk->{$y});
        $chunk->run_filters unless $chunk->is_filtered;
        is($chunk->$x, $chunk->$y,
           $chunk->name ? $chunk->name : ()
          );
    }
}

sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    my ($x, $y) = @_;
    for my $chunk (@{$self->chunk_list}) {
        next unless exists($chunk->{$x}) and exists($chunk->{$y});
        $chunk->run_filters unless $chunk->is_filtered;
        is_deeply($chunk->$x, $chunk->$y,
           $chunk->name ? $chunk->name : ()
          );
    }
}

sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    my ($x, $y) = @_;
    for my $chunk (@{$self->chunk_list}) {
        next unless exists($chunk->{$x}) and defined($y);
        $chunk->run_filters unless $chunk->is_filtered;
        my $regexp = ref $y ? $y : $chunk->$y;
        like($chunk->$x, $regexp,
             $chunk->name ? $chunk->name : ()
            );
    }
}

sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    my ($x, $y) = @_;
    for my $chunk (@{$self->chunk_list}) {
        next unless exists($chunk->{$x}) and defined($y);
        $chunk->run_filters unless $chunk->is_filtered;
        my $regexp = ref $y ? $y : $chunk->$y;
        unlike($chunk->$x, $regexp,
               $chunk->name ? $chunk->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 _chunk_list_init {
    my $spec = $self->spec;
    $spec = $self->_pre_eval($spec);
    my $cd = $self->chunk_delim;
    my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
    my $chunks = $self->_choose_chunks(@hunks);
    $self->chunk_list($chunks); # Need to set early for possible filter use
    my $seq = 1;
    for my $chunk (@$chunks) {
        $chunk->chunks_object($self);
        $chunk->seq_num($seq++);
    }
    return $chunks;
}

sub _choose_chunks {
    my $chunks = [];
    for my $hunk (@_) {
        my $chunk = $self->_make_chunk($hunk);
        if (exists $chunk->{ONLY}) {
            return [$chunk];
        }
        next if exists $chunk->{SKIP};
        push @$chunks, $chunk;
        if (exists $chunk->{LAST}) {
            return $chunks;
        }
    }
    return $chunks;
}

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_chunk {
    my $hunk = shift;
    my $cd = $self->chunk_delim;
    my $dd = $self->data_delim;
    my $chunk = $self->chunk_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//;
    $chunk->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;
        $section_map->{$type} = {
            filters => $filters,
        };
        push @$section_order, $type;
        $chunk->set_value($type, $value);
    }
    $chunk->set_value(name => $name);
    $chunk->set_value(_section_map => $section_map);
    $chunk->set_value(_section_order => $section_order);
    return $chunk;
}

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 = ;
        close FILE;
    }
    else {
        $spec = do {
            package main;
            no warnings 'once';
            ;
        };
    }
    return $spec;
}

# XXX Copied from Spiffy. Refactor at some point.
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::Chunks::Handle', $_[0];
}

package Test::Chunks::Handle;

sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}

sub PRINT {
    $$self .= $_ for @_;
}

#===============================================================================
# Test::Chunks::Chunk
#
# This is the default class for accessing a Test::Chunks chunk object.
#===============================================================================
package Test::Chunks::Chunk;
our @ISA = qw(Spiffy);

our @EXPORT = qw(chunk_accessor);

sub chunk_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];
    };
}

chunk_accessor 'name';
chunk_accessor 'description';
Spiffy::field 'seq_num';
Spiffy::field 'is_filtered';
Spiffy::field 'chunks_object';
Spiffy::field 'original_values' => {};

sub set_value {
    no strict 'refs';
    my $accessor = shift;
    chunk_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 chunk 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::Chunks::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/
                ) {
                    @value = ($_);
                }
            }
            else {
                my $filter_object = $self->chunks_object->filter_class->new;
                die "Can't find a function or method for '$filter' filter\n"
                  unless $filter_object->can($filter);
                $filter_object->chunk($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->chunks_object->_filters_map->{$type} || [];
    $map_filters = [ $map_filters ] unless ref $map_filters;
    my @append = ();
    for (
        @{$self->chunks_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 {
            @filters = grep { $_ ne $filter } @filters;
            push @filters, $filter;
        }
    }
    return @filters, @append;
}

{
    %$reserved_section_names = map {
        ($_, 1);
    } keys(%Test::Chunks::Chunk::), qw( new DESTROY );
}

#===============================================================================
# Test::Chunks::Filter
#
# This is the default class for handling Test::Chunks data filtering.
#===============================================================================
package Test::Chunks::Filter;
use Spiffy -base;

field 'chunk';

our $arguments;
sub arguments {
    return undef unless defined $arguments;
    my $args = $arguments;
    $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 norm {
    $self->assert_scalar(@_);
    my $text = shift || '';
    $text =~ s/\015\012/\n/g;
    $text =~ s/\r/\n/g;
    return $text;
}

sub chomp {
    map { CORE::chomp; $_ } @_;
}

sub unchomp {
    map { $_ . "\n" } @_;
}

sub chop {
    map { CORE::chop; $_ } @_;
}

sub append {
    my $suffix = $self->arguments;
    map { $_ . $suffix } @_;
}

sub trim {
    map {
        s/\A([ \t]*\n)+//;
        s/(?<=\n)\s*\z//g;
        $_;
    } @_;
}

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 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_stdout {
    $self->assert_scalar(@_);
    my $output = '';
    Test::Chunks::tie_output(*STDOUT, $output);
    CORE::eval(shift);
    no warnings;
    untie *STDOUT;
    return $output;
}

sub eval_stderr {
    $self->assert_scalar(@_);
    my $output = '';
    Test::Chunks::tie_output(*STDERR, $output);
    CORE::eval(shift);
    no warnings;
    untie *STDERR;
    return $output;
}

sub eval_all {
    $self->assert_scalar(@_);
    my $out = '';
    my $err = '';
    Test::Chunks::tie_output(*STDOUT, $out);
    Test::Chunks::tie_output(*STDERR, $err);
    my $return = CORE::eval(shift);
    no warnings;
    untie *STDOUT;
    untie *STDERR;
    return $return, $@, $out, $err;
}

sub exec_perl_stdout {
    my $tmpfile = "/tmp/test-chunks-$$";
    $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 _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";
}

sub yaml {
    $self->assert_scalar(@_);
    require YAML;
    return YAML::Load(shift);
}

sub lines {
    $self->assert_scalar(@_);
    my $text = shift;
    return () unless length $text;
    my @lines = ($text =~ /^(.*\n?)/gm);
    return @lines;
}

sub array {
    [@_];
}

sub join {
    my $string = $self->arguments;
    $string = '' unless defined $string;
    CORE::join $string, @_;
}

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 strict {
    $self->assert_scalar(@_);
    <<'...' . shift;
use strict;
use warnings;
...
}

sub regexp {
    $self->assert_scalar(@_);
    my $text = shift;
    my $flags = $self->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 get_url {
    $self->assert_scalar(@_);
    my $url = shift;
    CORE::chomp($url);
    require LWP::Simple;
    LWP::Simple::get($url);
}

__DATA__