t/op/attrs.t

   1 #!./perl -w
   2
   3 # Regression tests for attributes.pm and the C< : attrs> syntax.
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = '../lib';
   8 }
   9
  10 sub NTESTS () ;
  11
  12 my ($test, $ntests);
  13 BEGIN {$ntests=0}
  14 $test=0;
  15 my $failed = 0;
  16
  17 print "1..".NTESTS."\n";
  18
  19 $SIG{__WARN__} = sub { die @_ };
  20
  21 sub mytest {
  22     my $bad = '';
  23     if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) {
  24         if ($@) {
  25             my $x = $@;
  26             $x =~ s/\n.*\z//s;
  27             print "# Got: $x\n"
  28         }
  29         else {
  30             print "# Got unexpected success\n";
  31         }
  32         if ($_[0]) {
  33             print "# Expected: $_[0]\n";
  34         }
  35         else {
  36             print "# Expected success\n";
  37         }
  38         $failed = 1;
  39         $bad = 'not ';
  40     }
  41     elsif (@_ == 3 && $_[1] ne $_[2]) {
  42         print "# Got: $_[1]\n";
  43         print "# Expected: $_[2]\n";
  44         $failed = 1;
  45         $bad = 'not ';
  46     }
  47     print $bad."ok ".++$test."\n";
  48 }
  49
  50 eval 'sub t1 ($) : locked { $_[0]++ }';
  51 mytest;
  52 BEGIN {++$ntests}
  53
  54 eval 'sub t2 : locked { $_[0]++ }';
  55 mytest;
  56 BEGIN {++$ntests}
  57
  58 eval 'sub t3 ($) : locked ;';
  59 mytest;
  60 BEGIN {++$ntests}
  61
  62 eval 'sub t4 : locked ;';
  63 mytest;
  64 BEGIN {++$ntests}
  65
  66 my $anon1;
  67 eval '$anon1 = sub ($) : locked:method { $_[0]++ }';
  68 mytest;
  69 BEGIN {++$ntests}
  70
  71 my $anon2;
  72 eval '$anon2 = sub : locked : method { $_[0]++ }';
  73 mytest;
  74 BEGIN {++$ntests}
  75
  76 my $anon3;
  77 eval '$anon3 = sub : method { $_[0]->[1] }';
  78 mytest;
  79 BEGIN {++$ntests}
  80
  81 eval 'sub e1 ($) : plugh ;';
  82 mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/;
  83 BEGIN {++$ntests}
  84
  85 eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
  86 mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /;
  87 BEGIN {++$ntests}
  88
  89 eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
  90 mytest qr/Unterminated attribute parameter in attribute list at/;
  91 BEGIN {++$ntests}
  92
  93 eval 'sub e4 ($) : plugh + xyzzy ;';
  94 mytest qr/Invalid separator character '[+]' in attribute list at/;
  95 BEGIN {++$ntests}
  96
  97 eval 'my main $x : = 0;';
  98 mytest;
  99 BEGIN {++$ntests}
 100
 101 eval 'my $x : = 0;';
 102 mytest;
 103 BEGIN {++$ntests}
 104
 105 eval 'my $x ;';
 106 mytest;
 107 BEGIN {++$ntests}
 108
 109 eval 'my ($x) : = 0;';
 110 mytest;
 111 BEGIN {++$ntests}
 112
 113 eval 'my ($x) ;';
 114 mytest;
 115 BEGIN {++$ntests}
 116
 117 eval 'my ($x) : ;';
 118 mytest;
 119 BEGIN {++$ntests}
 120
 121 eval 'my ($x,$y) : = 0;';
 122 mytest;
 123 BEGIN {++$ntests}
 124
 125 eval 'my ($x,$y) ;';
 126 mytest;
 127 BEGIN {++$ntests}
 128
 129 eval 'my ($x,$y) : ;';
 130 mytest;
 131 BEGIN {++$ntests}
 132
 133 eval 'my ($x,$y) : plugh;';
 134 mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/;
 135 BEGIN {++$ntests}
 136
 137 sub A::MODIFY_SCALAR_ATTRIBUTES { return }
 138 eval 'my A $x : plugh;';
 139 mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/;
 140 BEGIN {++$ntests}
 141
 142 eval 'my A $x : plugh plover;';
 143 mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
 144 BEGIN {++$ntests}
 145
 146 eval 'package Cat; my Cat @socks;';
 147 mytest qr/^Can't declare class for non-scalar \@socks in "my"/;
 148 BEGIN {++$ntests}
 149
 150 sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
 151 sub X::foo { 1 }
 152 *Y::bar = \&X::foo;
 153 *Y::bar = \&X::foo;     # second time for -w
 154 eval 'package Z; sub Y::bar : foo';
 155 mytest qr/^X at /;
 156 BEGIN {++$ntests}
 157
 158 eval 'package Z; sub Y::baz : locked {}';
 159 my @attrs = eval 'attributes::get \&Y::baz';
 160 mytest '', "@attrs", "locked";
 161 BEGIN {++$ntests}
 162
 163 @attrs = eval 'attributes::get $anon1';
 164 mytest '', "@attrs", "locked method";
 165 BEGIN {++$ntests}
 166
 167 sub Z::DESTROY { }
 168 sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' }
 169 my $thunk = eval 'bless +sub : method locked { 1 }, "Z"';
 170 mytest '', ref($thunk), "Z";
 171 BEGIN {++$ntests}
 172
 173 @attrs = eval 'attributes::get $thunk';
 174 mytest '', "@attrs", "locked method Z";
 175 BEGIN {++$ntests}
 176
 177 # Test ability to modify existing sub's (or XSUB's) attributes.
 178 eval 'package A; sub X { $_[0] } sub X : lvalue';
 179 @attrs = eval 'attributes::get \&A::X';
 180 mytest '', "@attrs", "lvalue";
 181 BEGIN {++$ntests}
 182
 183 # Above not with just 'pure' built-in attributes.
 184 sub Z::MODIFY_CODE_ATTRIBUTES { (); }
 185 eval 'package Z; sub L { $_[0] } sub L : Z lvalue';
 186 @attrs = eval 'attributes::get \&Z::L';
 187 mytest '', "@attrs", "lvalue Z";
 188 BEGIN {++$ntests}
 189
 190
 191 # Begin testing attributes that tie
 192
 193 {
 194     package Ttie;
 195     sub DESTROY {}
 196     sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; }
 197     sub FETCH { ${$_[0]} }
 198     sub STORE {
 199         #print "# In Ttie::STORE\n";
 200         ::mytest '';
 201         ${$_[0]} = $_[1]*2;
 202     }
 203     package Tloop;
 204     sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); }
 205 }
 206
 207 eval '
 208     package Tloop;
 209     for my $i (0..2) {
 210         my $x : TieLoop = $i;
 211         $x != $i*2 and ::mytest "", $x, $i*2;
 212     }
 213 ';
 214 mytest;
 215 BEGIN {$ntests += 4}
 216
 217 # Other tests should be added above this line
 218
 219 sub NTESTS () { $ntests }
 220
 221 exit $failed;