view release on metacpan or  search on metacpan

local/lib/perl5/Test/Trap/Builder.pm  view on Meta::CPAN

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:

local/lib/perl5/Test/Trap/Builder.pm  view on Meta::CPAN

  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__

=head1 NAME

Test::Trap::Builder - Backend for building test traps

=head1 VERSION

Version 0.3.5

=head1 SYNOPSIS

  package My::Test::Trap;

  use Test::Trap::Builder;
  my $B = Test::Trap::Builder->new;

  $B->layer( $layer_name => \&layer_implementation );
  $B->accessor( simple => [ $layer_name ] );

  $B->multi_layer( $multi_name => @names );

  $B->test( $test_name => 'trap, predicate, name', \&test_function );

=head1 DESCRIPTION

L<Test::Trap> neither traps nor tests everything you may want to trap
or test.  So, Test::Trap::Builder provides methods to write your own
trap layers, accessors, and test callbacks -- preferably for use with
your own modules (trappers).

Note that layers are methods with mangled names (names are prefixed
with C<layer:>), and so inherited like any other method, while
accessors are ordinary methods.  Meanwhile, test callbacks are not
referenced in the symbol table by themselves, but only in combinations
with accessors, all methods of the form I<ACCESSOR>_I<TEST>.