File Coverage

blib/lib/Test/Trap/Builder.pm

Criterion	Covered	Total	%
statement	270	276	97.8
branch	68	68	100.0
condition	22	23	95.6
subroutine	52	52	100.0
pod	18	18	100.0
total	430	437	98.4

package Test::Trap::Builder;

use version; $VERSION = qv('0.3.5');

use strict;
use warnings;
use Data::Dump qw(dump);
BEGIN {
  use Exporter ();
  *import = \&Exporter::import;
  my @methods = qw( Next Exception ExceptionFunction Teardown Run TestAccessor TestFailure Prop DESTROY );
  our @EXPORT_OK = (@methods);
  our %EXPORT_TAGS = ( methods => \@methods );
}
use constant GOT_CARP_NOT => $] >= 5.008;
use Carp qw(croak);
our (@CARP_NOT, @ISA);

my $builder = bless {};

# Methods on the trap object ... basically a trap object "base class":

BEGIN {
  my %Prop;
  my $prefix = "$^T/$$/";
  my $counter;

  sub DESTROY {
    my $self = shift;
    delete $Prop{ $self->{' id '} || '' };
  }

  sub Prop {
    my $self = shift;
    my ($package) = @_;
    $package = caller unless $package;
    $self->{' id '} = $prefix . ++$counter unless $self->{' id '};
    return $Prop{$self->{' id '}}{$package} ||= {};
  }

  sub Next { goto &{ pop @{$_[0]->Prop->{layers}} } }

  sub Teardown { my $self = shift; push @{$self->Prop->{teardown}}, @_ }

  sub Run { my $self = shift; @_ = (); goto &{$self->Prop->{code}} }

  sub TestAccessor { shift->Prop->{test_accessor} }

  sub TestFailure {
    my $self = shift;
    my $m = $self->Prop->{on_test_failure} or return;
    $self->$m(@_);
  }

  sub ExceptionFunction {
    my $self = shift;
    my $exception = $self->Prop->{exception} ||= [];
    $self->Prop->{exception_function} ||= sub {
      push @$exception, @_;
      local *@;
      eval {
        no warnings 'exiting';
        last TEST_TRAP_BUILDER_INTERNAL_EXCEPTION;
      };
      # XXX: PANIC!  We returned!?!
      CORE::exit(8); # XXX: Is there a more appropriate exit value?
    };
    return $self->Prop->{exception_function};
  }

  sub Exception {
    my $self = shift;
    $self->ExceptionFunction->(@_);
  }
}

# Utility functions and methods on the builder class/object:

sub _carpnot_for (@) {
  my %seen = ( __PACKAGE__, 1 );
  my @pkg = grep { !$seen{$_}++ } @_;
  return @pkg;
}

sub new { $builder }

sub trap {
  my $self = shift;
  my ($trapper, $glob, $layers, $code) = @_;
  my $trap = bless { wantarray => (my $wantarray = wantarray) }, $trapper;
TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: {
    local *@;
    local $trap->Prop->{code} = $code;
    $trap->Prop->{layers}     = [@$layers];
    $trap->Prop->{teardown}   = [];
  TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: {
      eval { $trap->Next; 1} or $trap->Exception("Rethrowing internal exception: $@");
    }
    for (reverse @{$trap->Prop->{teardown}}) {
    TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: {
	eval { $_->(); 1} or $trap->Exception("Rethrowing teardown exception: $@");
      }
    }
    last if @{$trap->Prop->{exception}||[]};
    ${*$glob} = $trap;
    my @return = eval { @{$trap->return} };
    return $wantarray ? @return : $return[0];
  }
  local( GOT_CARP_NOT ? @CARP_NOT : @ISA ) = _carpnot_for $trapper, scalar caller;
  croak join"\n", @{$trap->Prop->{exception}};
}

BEGIN { # The register (private) functions:
  my %register;
  sub _register {
    my ($type, $package, $name, $val) = @_;
    $register{$type}{$package}{$name} = $val;
  }
  sub _register_packages {
    my ($type) = @_;
    return keys %{$register{$type}};
  }
  sub _register_names {
    my ($type, $package) = @_;
    return keys %{$register{$type}{$package}};
  }
  sub _register_value {
    my ($type, $package, $name) = @_;
    return $register{$type}{$package}{$name};
  }
}

BEGIN { # Test callback registration and test method generation:
  # state for the closures in %argspec -- obviously not reentrant:
  my ($accessor, $test, $index, $trap, @arg);
  my %argspec =
    ( trap      => sub { $trap },
      element   => sub { $accessor->{code}->( $trap, _need_index() ? $index = shift(@arg) : () ) },
      entirety  => sub { $accessor->{code}->( $trap ) },
      predicate => sub { shift @arg },
      name      => sub { shift @arg },
    );
  # backwards compatibility -- don't use these:
  @argspec{ qw( object all indexed ) } = @argspec{ qw( trap entirety element ) };
  # stringifying the CODE refs, that we may easily check if we have a specific one:
  my %isname    = ( $argspec{name}      => 1 );
  my %iselement = ( $argspec{element}   => 1 );
  my %takesarg  = ( $argspec{predicate} => 1 );

  sub _need_index { $accessor->{is_array} && grep $iselement{$_}, @{$test->{argspec}} }

  # a single universal test -- the leaveby test:
  # (don't worry -- the UNIVERSAL package is not actually touched)
  _register test => UNIVERSAL => did =>
    { argspec => [ $argspec{name} ],
      code    => sub { require Test::More; goto &Test::More::pass },
      pattern => '%s::did_%s',
      builder => __PACKAGE__->new,
    };

  my $basic_test = sub {
    ($accessor, $test, $trap, @arg) = @_;
    $index = '';
    my @targs = map $_->(), @{$test->{argspec}};
    my $ok;
    local $trap->Prop->{test_accessor} = "$accessor->{name}($index)";
    local $Test::Builder::Level = $Test::Builder::Level+1;

    # Work around perl5 bug #119683, as per Test-Trap bug #127112:
    my @copy = ($!, $^E);
    local ($!, $^E) = @copy;

    $ok = $test->{code}->(@targs) or $trap->TestFailure;
    $ok;
  };

  my $wrong_leaveby = sub {
    ($accessor, $test, $trap, @arg) = @_;
    require Test::More;
    my $Test = Test::More->builder;
    my $test_name_index = 0;
    for (@{$test->{argspec}}) {
      last if $isname{$_};
      $test_name_index++ if $takesarg{$_} or $accessor->{is_array} && $iselement{$_};
    }
    my $ok = $Test->ok('', $arg[$test_name_index]);
    my $got = $trap->leaveby;
    $Test->diag(sprintf<{name}, $got, dump($trap->$got));
    Expecting to %s(), but instead %s()ed with %s
DIAGNOSTIC
    $trap->TestFailure;
    $ok;
  };

  sub _accessor_test {
    my ($apkgs, $anames, $tpkgs, $tnames) = @_;
    for my $apkg (@$apkgs ? @$apkgs : _register_packages 'accessor') {
      for my $aname (@$anames ? @$anames : _register_names accessor => $apkg) {
	my $adef = _register_value accessor => $apkg => $aname;
	for my $tpkg (@$tpkgs ? @$tpkgs : _register_packages 'test') {
	  my $mpkg = $apkg->isa($tpkg) ? $apkg
		   : $tpkg->isa($apkg) ? $tpkg
		   : next;
	  for my $tname (@$tnames ? @$tnames : _register_names test => $tpkg) {
	    my $tdef = _register_value test => $tpkg => $tname;
	    my $mname = sprintf $tdef->{pattern}, $mpkg, $aname;
	    no strict 'refs';
	    *$mname = sub {
	      my ($trap) = @_;
	      unshift @_, $adef, $tdef;
	      goto &$wrong_leaveby if $adef->{is_leaveby} and $trap->leaveby ne $adef->{name};
	      goto &$basic_test;
	    };
	  }
	}
      }
    }
  }

  sub test {
    my $self = shift;
    my ($tname, $targs, $code) = @_;
    my $tpkg = caller;
    my @targs = map { $argspec{$_} || croak "Unrecognized identifier $_ in argspec" } $targs =~ /(\w+)/g;
    _register test => $tpkg => $tname =>
      { argspec => \@targs,
	code    => $code,
	pattern => "%s::%s_$tname",
	builder => $self,
      };
    # make the test methods:
    _accessor_test( [], [], [$tpkg], [$tname] );
  }
}

BEGIN { # Accessor registration:
  my $export_accessor = sub {
    my ($apkg, $aname, $par, $code) = @_;
    no strict 'refs';
    *{"$apkg\::$aname"} = $code;
    _register accessor => $apkg => $aname =>
      { %$par,
	code => $code,
	name => $aname,
      };
    # make the test methods:
    _accessor_test( [$apkg], [$aname], [], [] );
  };

  my %accessor_factory =
    ( scalar => sub {
	my $name = shift;
	return sub { $_[0]{$name} };
      },
      array => sub {
	my $name = shift;
	return sub {
	  my $trap = shift;
	  return   $trap->{$name}      unless @_;
	  return @{$trap->{$name}}[@_] if wantarray;
	  return   $trap->{$name}[shift];
	};
      },
    );

  sub accessor {
    my $self = shift;
    my %par = @_;
    my $simple = delete $par{simple};
    my $flexible = delete $par{flexible};
    my $pkg = caller;
    for my $name (keys %{$flexible||{}}) {
      $export_accessor->($pkg, $name, \%par, $flexible->{$name});
    }
    my $factory = $accessor_factory{ $par{is_array} ? 'array' : 'scalar' };
    for my $name (@{$simple||[]}) {
      $export_accessor->($pkg, $name, \%par, $factory->($name));
    }
  }
}

BEGIN { # Layer registration:
  my $export_layer = sub {
    my ($pkg, $name, $sub) = @_;
    no strict 'refs';
    *{"$pkg\::layer:$name"} = $sub;
  };

  sub layer {
    my $self = shift;
    my ($name, $sub) = @_;
    $export_layer->(scalar caller, $name, sub { my ($self, @arg) = @_; sub { shift->$sub(@arg) } });
  }

  sub multi_layer {
    my $self = shift;
    my $name = shift;
    my $callpkg = caller;
    my @layer = $self->layer_implementation($callpkg, @_);
    $export_layer->($callpkg, $name, sub { @layer });
  }

  sub output_layer {
    my $self = shift;
    my ($name, $globref) = @_;
    my $code = sub {
      my $class = shift;
      my ($arg) = @_;
      my $strategy = $self->first_capture_strategy($arg);
      return sub {
	my $trap = shift;
	$trap->{$name} = ''; # XXX: Encapsulation violation!
	my $fileno;
	# common stuff:
	unless (tied *$globref or defined($fileno = fileno *$globref)) {
	  return $trap->Next;
	}
	my $m = $strategy; # placate Devel::Cover:
	$m = $trap->Prop->{capture_strategy} unless $m;
	$m = $self->capture_strategy('tempfile') unless $m;
	$trap->$m($name, $fileno, $globref);
      };
    };
    $export_layer->(scalar caller, $name, $code);
  }
}

BEGIN {
  my %strategy;
  # Backwards compatibility aliases; don't use:
  *output_layer_backend = \&capture_strategy;
  *first_output_layer_backend = \&first_capture_strategy;
  sub capture_strategy {
    my $this = shift;
    my ($name, $strategy) = @_;
    $strategy{$name} = $strategy if $strategy;
    return $strategy{$name};
  }
  sub first_capture_strategy {
    my $self = shift;
    my ($arg) = @_;
    return unless $arg;
    my @strategy = split /[,;]/, $arg;
    for (@strategy) {
      my $strategy = $self->capture_strategy($_);
      return $strategy if $strategy;
    }
    croak "No capture strategy found for " . dump(@strategy);
  }
}

sub layer_implementation {
  my $self = shift;
  # Directly querying layer implementation, we should know what we're doing:
  local( GOT_CARP_NOT ? @CARP_NOT : @ISA ) = _carpnot_for caller;
  my $trapper = shift;
  my @r;
  for (@_) {
    if ( length ref and eval { exists &$_ } ) {
      push @r, $_;
      next;
    }
    my ($name, $arg) =
      /^ ( [^\(]+ )      # layer name: anything but '('
         (?:             # begin optional group
             \(          # literal '('
             ( [^\)]* )  # arg: anything but ')'
             \)          # literal ')'
         )?              # end optional group
      \z/x;
    my $meth = $trapper->can("layer:$name")
      or croak qq[Unknown trap layer "$_"];
    push @r, $trapper->$meth($arg);
  }
  return @r;
}

1; # End of Test::Trap::Builder

__END__