The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use 5.014;
use Test::Spec;
require Test::NoWarnings;

use FindBin qw/ $Bin /;
use lib "$Bin/lib";
use test_tools qw/ test_syntax_error compile_ok /;

use Exception::Class 'Error1';
use syntax 'try';


my @RET_TYPES = qw/ array list scalar undef none /;

sub mock_return {
    my $mode = shift;
    if ($mode eq 'array') {
        my @a = qw/ aa bb cc dd /;
        return @a;
    }
    elsif ($mode eq 'list') {
        return (444,666,777);
    }
    elsif ($mode eq 'scalar') {
        return 53.3;
    }
    elsif ($mode eq 'undef') {
        return undef;
    }
    return;
}

describe "return" => sub {

    describe "from mock function" => sub {
        it "is ok" => sub {
            is_deeply([ mock_return('array') ], [qw/ aa bb cc dd /]);
            is_deeply(scalar mock_return('array'), 4);

            is_deeply([ mock_return('list') ], [qw/ 444 666 777 /]);
            is_deeply(scalar(mock_return('list')), 777);

            is_deeply([ mock_return('scalar') ], [53.3]);
            is_deeply(scalar mock_return('scalar'), 53.3);

            is_deeply([ mock_return('undef') ], [undef]);
            is_deeply(scalar mock_return('undef'), undef);

            is_deeply([ mock_return('none') ], []);
            is_deeply(scalar mock_return('none'), undef);
        };
    };

    describe "from try block" => sub {
        it "works ok" => sub {
            our @done = ();

            sub test_return_try {
                my ($x) = @_;

                push @done, 'before';
                try {
                    push @done, 'try-1';
                    return 66;

                    push @done, 'try-2';
                }
                catch (Error1 $e) {
                    push @done, 'catch';
                    return 77;
                }
                finally {
                    push @done, 'finally';
                }
                return 88;
            }

            is_deeply(test_return_try(), 66);

            is_deeply(\@done, [qw/ before try-1 finally /]);
        };

        it "works in all contexts" => sub {
            sub test_try_context {
                my $mode = shift;
                try {
                    return mock_return($mode);
                }
                finally { }
                die "This-is-never-called";
            }

            for (@RET_TYPES) {
                is_deeply(scalar test_try_context($_), scalar mock_return($_));
                is_deeply([test_try_context($_)], [mock_return($_)]);
                test_try_context($_); # void context
            }
        };
    };

    describe "from catch block" => sub {
        it "works inside catch block" => sub {
            our @done = ();

            sub test_return_catch {
                my ($x) = @_;

                push @done, 'before';
                try {
                    push @done, 'try-1';
                    Error1->throw;

                    push @done, 'try-2';
                    return 66;
                }
                catch (Error1 $e) {
                    push @done, 'catch';
                    return 77;
                }
                finally {
                    push @done, 'finally';
                }
                return 88;
            }

            is_deeply(test_return_catch(), 77);

            is_deeply(\@done, [qw/ before try-1 catch finally /]);
        };

        it "works in all contexts" => sub {
            sub test_catch_context {
                my $mode = shift;
                try { Error1->throw }
                catch (Error1 $err) {
                    return mock_return($mode);
                }
                die "This-is-never-called";
            }

            for (@RET_TYPES) {
                is_deeply(scalar test_catch_context($_), scalar mock_return($_));
                is_deeply([test_catch_context($_)], [mock_return($_)]);
                test_catch_context($_); # void context
            }
        };
    };

    describe "from finally block" => sub {
        it "works ok" => sub {
            our @done = ();

            sub test_return_finally {
                my ($x) = @_;

                push @done, 'before';
                try {
                    push @done, 'try-1';
                    Error1->throw;
                    return 66;
                }
                catch (Error1 $e) {
                    push @done, 'catch';
                }
                finally {
                    push @done, 'finally';
                    return 99;
                }
                return 88;
            }

            is_deeply(test_return_finally(), 99);

            is_deeply(\@done, [qw/ before try-1 catch finally /]);
        };

        it "overrides prevoiusly returned values" => sub {
            sub test_override_return {
                my $mode = shift;
                try {
                    Error1->throw if $mode eq 'err';
                    return 44;
                }
                catch (Error1 $e) {
                    return 55;
                }
                finally {
                    return 66;
                }
                return 99;
            }

            is(test_override_return('err'), 66);
            is(test_override_return('ok'), 66);
        };
    };

    it "works for nested blocks structures" => sub {
        sub test_nested_blocks {
            my $mode = shift;
            try {
                for (1..3) {
                    try {
                        Error1->throw if $mode eq 'ERROR';
                        return mock_return($mode) if $mode;
                    }
                    finally {
                    }
                }
            }
            catch (Error1 $e) {
                return 67;
            }
            return 5;
        }

        for (@RET_TYPES) {
            is_deeply(scalar test_nested_blocks($_), scalar mock_return($_));
            is_deeply([test_nested_blocks($_)], [mock_return($_)]);
            test_nested_blocks($_); # void context
        }

        is_deeply(scalar test_nested_blocks('ERROR'), 67);
        is_deeply([test_nested_blocks('ERROR')], [qw/ 67 /]);
        test_nested_blocks('ERROR'); # void context
    };

    it "can be used outside try/finally blocks" => sub {
        compile_ok q[
            use syntax 'try';

            my $a = sub { return 11 };
            sub t1 { return 111 }
            t1();

            try { }
            finally { }

            my $b = sub { return 22 };
            sub t2 { return 222 }
            t2();
        ];
    };

    it "can be used inside subroutines defined in try/catch/finally blocks" => sub {
        my @result = compile_ok q[
            use syntax 'try';

            my @res;
            try {
                my $t1 = sub {
                    return 6;
                    return 7;
                };
                push @res, $t1->();

                die bless {}, "Mock::Err";
            }
            catch (Mock::Err $e) {
                my $t2 = sub {
                    return 8;
                    return 9;
                };
                push @res, $t2->();
            }
            return @res;
        ];

        is_deeply(\@result, [6,8]);
    };

    it "can be used outside try/catch/finally blocks" => sub {
        compile_ok q[
            use syntax 'try';

            sub test_return {
                my $x = shift;

                return 55 if $x;

                try {
                }
                catch (Mock::Err $e) {
                }

                return 99;
            }
        ];
    };
};

it "has no warnings" => sub {
    Test::NoWarnings::had_no_warnings();
};

runtests;