#! /usr/bin/perl
# $Id: 21_exceptions.t,v 1.6 2009/12/01 23:01:52 dk Exp $

alarm(10);

use strict;
use warnings;
use Test::More;
use IO::Lambda qw(:lambda);

plan tests => 25;

# just throw
sub throw
{
	lambda { this-> throw('throw') }
}

# exceptions pass through
sub bypass
{
	my $listen = shift;
	lambda {
		context $listen;
		tail { 'pass' };
	}
}

# just a fork
sub forks
{
	my @t = @_;
	lambda {
		context @t;
		tails { @_ }
	}
}

# catch expection, do not propagate further
sub caught
{
	my $listen = shift;
	lambda {
		context $listen;
		catch { 'caught', @_ }
		tail  { 'passed', @_ }
	}
}

# bypass expection but alter the result
sub fin
{
	my $listen = shift;
	lambda {
		context $listen;
		catch    { this-> throw('finally') }
		tail     { 'finally' }
	}
}

# normal exceptions
ok( throw-> wait eq 'throw', 'throw');
ok( bypass(lambda{})-> wait eq 'pass', 'pass');
ok( bypass(throw)-> wait eq 'throw', 'bypass/1');
ok( fin(throw)-> wait eq 'finally', 'finally');
ok( forks(throw)-> wait eq 'throw', 'bypass/*');
ok( caught(throw)-> wait eq 'caught', 'catch');
ok( caught(fin(throw))-> wait eq 'caught', 'finally bypasses ok');
ok( fin(caught(throw))-> wait eq 'finally', 'finally/catch');
ok( caught(bypass(throw))-> wait eq 'caught', 'catch/bypass');
ok( fin(caught(bypass(throw)))-> wait eq 'finally', 'finally/catch/bypass');
ok( caught(caught(throw))-> wait eq 'passed', 'catch/catch');

# SIGTHROW
my $sig = 0;
IO::Lambda-> sigthrow( sub { $sig++ });
throw-> wait;
ok( $sig, 'sigthrow on');

$sig = 0;
IO::Lambda-> sigthrow(undef);
throw-> wait;
ok( 0 == $sig, 'sigthrow off');

IO::Lambda::sigthrow( sub { $sig++ });
throw-> wait;
ok( $sig, 'sigthrow on');

$sig = 0;
IO::Lambda::sigthrow(undef);
throw-> wait;
ok( 0 == $sig, 'sigthrow off');

# stack
sub stack
{
	lambda {
		context 0.001;
	# make sure that lambdas wait for each other before throw is called
	timeout {
		this-> throw( this-> backtrace )
	}}
}

my $s = stack-> wait;
ok((1 == @$s and 1 == @{$s->[0]}), 'stack 1/1');

$s = bypass( stack )-> wait;
ok((1 == @$s and 2 == @{$s->[0]}), 'stack 1/2');

$s = bypass( bypass( stack ))-> wait;
ok((1 == @$s and 3 == @{$s->[0]}), 'stack 1/3');

my $x = stack;
$s = forks($x, $x)-> wait;
ok((2 == @$s and 2 == @{$s->[0]} and 2 == @{$s->[1]}), 'stack 2/2/2');

$x = stack;
$s = forks(bypass($x), bypass($x))-> wait;
ok((2 == @$s and 3 == @{$s->[0]} and 3 == @{$s->[1]}), 'stack 2/3/3');

$x = stack;
$x = bypass($x);
$s = forks(bypass($x), bypass($x))-> wait;
ok((2 == @$s and 4 == @{$s->[0]} and 4 == @{$s->[1]}), 'stack 2/4/4');

# check that catch() is restartable
my $ret = 0;
$x = lambda {
    context lambda {
	context 0.01;
	catch   { $ret |= 1 }
	timeout { $ret |= 2; again };
    };
    catch { $ret |= 4 }
    tail  { $ret |= 8 };
};

$x-> start;
lambda { context 0.1; &timeout }-> wait;
undef $x;
IO::Lambda::clear;
ok( $ret == 7, 'catch is restartable');


# check catch propagations
$ret = 0;
$x = lambda {
	context lambda {};
	catch {
		$ret |= 1;
		this-> call_again;
	} tail {
		$ret |= 2 if this-> is_cancelling;
	}
};
$x-> start;
undef $x;
ok($ret == 3, 'catch restarts event');

$ret = 0;
$x = lambda {
	context lambda {};
	autocatch tail { $ret |= 2 if this-> is_cancelling };
};
$x-> start;
undef $x;
ok($ret == 2, 'autocatch can restart');

# autocatch indeed rethrows
$ret = 0;
$x = lambda {
	context lambda {};
	autocatch tail { $ret |= 2 if this-> is_cancelling };
};
$x-> start;

lambda {
	context $x;
	catch { $ret |= 4; } tail {};
	$x-> throw(42);
}-> wait;
ok( $ret == 6, 'autocatch can rethrow');