The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

# Copied from 16_pointcut_returning with all the tests reversed.

use strict;
BEGIN {
	$|  = 1;
	$^W = 1;
}

use Test::More tests => 6;
use Test::NoWarnings;
use Test::Exception;
use Aspect;





######################################################################
# Test the regexp exception case

after {
	$_->exception('three');
} call qr/^Foo::/
& returning;

throws_ok(
	sub { Foo::one() },
	qr/^one/,
	'Hooked positive string exception is in the pointcut',
);

throws_ok(
	sub { Foo::two() },
	qr/^two/,
	'Hooked negative string exception is not in the pointcut',
);

throws_ok(
	sub { Foo::three() },
	'Exception1',
	'Hooked negative object exception is not in the pointcut',
);

throws_ok(
	sub { Foo::four() },
	'Exception2',
	'Hooked negative object exception is not in the pointcut',
);

throws_ok(
	sub { Foo::five() },
	qr/^three/,
	'Hooked non-exception was trapped and threw an exception',
);





######################################################################
# Support Classes

package Foo;

sub one {
	die 'one';
}

sub two {
	die 'two';
}

sub three {
	Exception1->throw('one');
}

sub four {
	Exception2->throw('two');
}

sub five {
	return 'five';
}

package Exception1;

sub throw {
	my $class = shift;
	my $self  = bless [ @_ ], $class;
	die $self;
}

package Exception2;

sub throw {
	my $class = shift;
	my $self  = bless [ @_ ], $class;
	die $self;
}

1;