#!./perl

# Testing the : prototype(..) attribute


BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
    skip_all_if_miniperl("miniperl can't load attributes");
}
use warnings;

plan tests => 48;

my @warnings;
my ($attrs, $ret) = ("", "");
sub Q::MODIFY_CODE_ATTRIBUTES { my ($name, $ref, @attrs) = @_; $attrs = "@attrs";return;}
$SIG{__WARN__} = sub { push @warnings, shift;};

$ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;';
is $ret, "bad", "Prototype is set to \"bad\"";
is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
like shift @warnings, "Illegal character in prototype for Q::A : bar",
    "First warning is bad prototype - bar";
like shift @warnings, "Illegal character in prototype for Q::A : bad",
    "Second warning is bad prototype - bad";
like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A',
    "Third warning is Prototype overridden";
is @warnings, 0, "No more warnings";

# The override warning should not be hidden by no warnings (similar to prototype changed warnings)
{
    no warnings 'illegalproto';
    $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;';
    is $ret, "bad", "Prototype is set to \"bad\"";
    is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
    like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B',
        "First warning is Prototype overridden";
    is @warnings, 0, "No more warnings";
}

# Redeclaring a sub with a prototype attribute ignores it
$ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;';
is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype";
is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
like shift @warnings, "Illegal character in prototype for Q::B : ignored",
    "Shifting off warning for the 'ignored' prototype";
like shift @warnings, "Illegal character in prototype for Q::B : baz",
    "Attempting to redeclare triggers Illegal character warning";
like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B',
    "Shifting off Prototype overridden warning";
like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)',
    "Attempting to redeclare triggers prototype mismatch warning against first prototype";
is @warnings, 0, "No more warnings";

# Confirm redifining with a prototype attribute takes it
$ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \&B;';
is $ret, "baz", "Redefining with prototype(..) changes the prototype";
is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
is &Q::B, 5, "Function successfully redefined";
like shift @warnings, "Illegal character in prototype for Q::B : ignored",
    "Attempting to redeclare triggers Illegal character warning";
like shift @warnings, "Illegal character in prototype for Q::B : baz",
    "Attempting to redeclare triggers Illegal character warning";
like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B',
    "Shifting off Prototype overridden warning";
like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)',
    "Attempting to redeclare triggers prototype mismatch warning";
like shift @warnings, 'Subroutine B redefined',
    "Only other warning is subroutine redefinition";
is @warnings, 0, "No more warnings";

# Multiple prototype declarations only takes the last one
$ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;';
is $ret, "\$\$\$", "Last prototype declared wins";
like shift @warnings, 'Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub',
    "Multiple prototype declarations warns";
is @warnings, 0, "No more warnings";

# Use attributes
eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";';
$ret = prototype \&Q::B;
is $ret, "new", "use attributes also sets the prototype";
like shift @warnings, 'Prototype mismatch: sub Q::B \(baz\) vs \(new\)',
    "Prototype mismatch warning triggered";
is @warnings, 0, "No more warnings";

eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";';
$ret = prototype \&Q::B;
is $ret, "new", "A malformed prototype doesn't reset it";
like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked";
is @warnings, 0, "Malformed prototype isn't just a warning";

eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";';
$ret = prototype \&Q::B;
is $ret, "new", "A malformed prototype doesn't reset it";
like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked";
is @warnings, 0, "Malformed prototype isn't just a warning";

# Anonymous subs (really just making sure they don't crash, since the prototypes
# themselves aren't much use)
{
    is eval 'package Q; my $a = sub(bar) : prototype(baz) {}; 1;', 1,
        "Sanity checking that eval of anonymous sub didn't croak";
    # The fact that the name is '?' in the first case
    # and __ANON__ in the second is due to toke.c temporarily setting
    # the name to '?' before calling the proto check, despite setting
    # it to the real name very shortly after.
    # In short - if this test breaks, just change the test.
    like shift @warnings, 'Illegal character in prototype for \? : bar',
        "(anon) bar triggers illegal proto warnings";
    like shift @warnings, "Illegal character in prototype for Q::__ANON__ : baz",
        "(anon) baz triggers illegal proto warnings";
    like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__',
        "(anon) overridden warning triggered in anonymous sub";
    is @warnings, 0, "No more warnings";
}

# Testing lexical subs
{
    use feature "lexical_subs";
    no warnings "experimental::lexical_subs";
    $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;';
    is $ret, "baz", "my sub foo honors the prototype attribute";
    like shift @warnings, 'Illegal character in prototype for foo : bar',
        "(lexical) bar triggers illegal proto warnings";
    like shift @warnings, "Illegal character in prototype for foo : baz",
        "(lexical) baz triggers illegal proto warnings";
    like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo',
        "(lexical) overridden warning triggered in anonymous sub";
    is @warnings, 0, "No more warnings";
}

# Local variables:
# indent-tabs-mode: nil
# End:
#
# ex: set ts=8 sts=4 sw=4 et: