t/op/attrproto.t

   1 #!./perl
   2
   3 # Testing the : prototype(..) attribute
   4
   5
   6 BEGIN {
   7     chdir 't' if -d 't';
   8     require './test.pl';
   9     set_up_inc('../lib');
  10     skip_all_if_miniperl("miniperl can't load attributes");
  11 }
  12 use warnings;
  13
  14 plan tests => 48;
  15
  16 my @warnings;
  17 my ($attrs, $ret) = ("", "");
  18 sub Q::MODIFY_CODE_ATTRIBUTES { my ($name, $ref, @attrs) = @_; $attrs = "@attrs";return;}
  19 $SIG{__WARN__} = sub { push @warnings, shift;};
  20
  21 $ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;';
  22 is $ret, "bad", "Prototype is set to \"bad\"";
  23 is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
  24 like shift @warnings, qr/Illegal character in prototype for Q::A : bar/,
  25     "First warning is bad prototype - bar";
  26 like shift @warnings, qr/Illegal character in prototype for Q::A : bad/,
  27     "Second warning is bad prototype - bad";
  28 like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/,
  29     "Third warning is Prototype overridden";
  30 is @warnings, 0, "No more warnings";
  31
  32 # The override warning should not be hidden by no warnings (similar to prototype changed warnings)
  33 {
  34     no warnings 'illegalproto';
  35     $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;';
  36     is $ret, "bad", "Prototype is set to \"bad\"";
  37     is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
  38     like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/,
  39         "First warning is Prototype overridden";
  40     is @warnings, 0, "No more warnings";
  41 }
  42
  43 # Redeclaring a sub with a prototype attribute ignores it
  44 $ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;';
  45 is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype";
  46 is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
  47 like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/,
  48     "Shifting off warning for the 'ignored' prototype";
  49 like shift @warnings, qr/Illegal character in prototype for Q::B : baz/,
  50     "Attempting to redeclare triggers Illegal character warning";
  51 like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/,
  52     "Shifting off Prototype overridden warning";
  53 like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/,
  54     "Attempting to redeclare triggers prototype mismatch warning against first prototype";
  55 is @warnings, 0, "No more warnings";
  56
  57 # Confirm redifining with a prototype attribute takes it
  58 $ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \&B;';
  59 is $ret, "baz", "Redefining with prototype(..) changes the prototype";
  60 is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
  61 is &Q::B, 5, "Function successfully redefined";
  62 like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/,
  63     "Attempting to redeclare triggers Illegal character warning";
  64 like shift @warnings, qr/Illegal character in prototype for Q::B : baz/,
  65     "Attempting to redeclare triggers Illegal character warning";
  66 like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/,
  67     "Shifting off Prototype overridden warning";
  68 like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/,
  69     "Attempting to redeclare triggers prototype mismatch warning";
  70 like shift @warnings, qr/Subroutine B redefined/,
  71     "Only other warning is subroutine redefinition";
  72 is @warnings, 0, "No more warnings";
  73
  74 # Multiple prototype declarations only takes the last one
  75 $ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;';
  76 is $ret, "\$\$\$", "Last prototype declared wins";
  77 like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/,
  78     "Multiple prototype declarations warns";
  79 is @warnings, 0, "No more warnings";
  80
  81 # Use attributes
  82 eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";';
  83 $ret = prototype \&Q::B;
  84 is $ret, "new", "use attributes also sets the prototype";
  85 like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/,
  86     "Prototype mismatch warning triggered";
  87 is @warnings, 0, "No more warnings";
  88
  89 eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";';
  90 $ret = prototype \&Q::B;
  91 is $ret, "new", "A malformed prototype doesn't reset it";
  92 like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
  93 is @warnings, 0, "Malformed prototype isn't just a warning";
  94
  95 eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";';
  96 $ret = prototype \&Q::B;
  97 is $ret, "new", "A malformed prototype doesn't reset it";
  98 like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
  99 is @warnings, 0, "Malformed prototype isn't just a warning";
 100
 101 # Anonymous subs (really just making sure they don't crash, since the prototypes
 102 # themselves aren't much use)
 103 {
 104     is eval 'package Q; my $a = sub(bar) : prototype(baz) {}; 1;', 1,
 105         "Sanity checking that eval of anonymous sub didn't croak";
 106     # The fact that the name is '?' in the first case
 107     # and __ANON__ in the second is due to toke.c temporarily setting
 108     # the name to '?' before calling the proto check, despite setting
 109     # it to the real name very shortly after.
 110     # In short - if this test breaks, just change the test.
 111     like shift @warnings, qr/Illegal character in prototype for \? : bar/,
 112         "(anon) bar triggers illegal proto warnings";
 113     like shift @warnings, qr/Illegal character in prototype for Q::__ANON__ : baz/,
 114         "(anon) baz triggers illegal proto warnings";
 115     like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/,
 116         "(anon) overridden warning triggered in anonymous sub";
 117     is @warnings, 0, "No more warnings";
 118 }
 119
 120 # Testing lexical subs
 121 {
 122     use feature "lexical_subs";
 123     no warnings "experimental::lexical_subs";
 124     $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;';
 125     is $ret, "baz", "my sub foo honors the prototype attribute";
 126     like shift @warnings, qr/Illegal character in prototype for foo : bar/,
 127         "(lexical) bar triggers illegal proto warnings";
 128     like shift @warnings, qr/Illegal character in prototype for foo : baz/,
 129         "(lexical) baz triggers illegal proto warnings";
 130     like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo/,
 131         "(lexical) overridden warning triggered in anonymous sub";
 132     is @warnings, 0, "No more warnings";
 133 }
 134
 135 # ex: set ts=8 sts=4 sw=4 et: