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     unshift @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     if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) {
  23         if ($@) {
  24             my $x = $@;
  25             $x =~ s/\n.*\z//s;
  26             print "# Got: $x\n"
  27         }
  28         else {
  29             print "# Got unexpected success\n";
  30         }
  31         if ($_[0]) {
  32             print "# Expected: $_[0]\n";
  33         }
  34         else {
  35             print "# Expected success\n";
  36         }
  37         $failed = 1;
  38         print "not ";
  39     }
  40     elsif (@_ == 3 && $_[1] ne $_[2]) {
  41         print "# Got: $_[1]\n";
  42         print "# Expected: $_[2]\n";
  43         $failed = 1;
  44         print "not ";
  45     }
  46     print "ok ",++$test,"\n";
  47 }
  48
  49 eval 'sub t1 ($) : locked { $_[0]++ }';
  50 mytest;
  51 BEGIN {++$ntests}
  52
  53 eval 'sub t2 : locked { $_[0]++ }';
  54 mytest;
  55 BEGIN {++$ntests}
  56
  57 eval 'sub t3 ($) : locked ;';
  58 mytest;
  59 BEGIN {++$ntests}
  60
  61 eval 'sub t4 : locked ;';
  62 mytest;
  63 BEGIN {++$ntests}
  64
  65 my $anon1;
  66 eval '$anon1 = sub ($) : locked:method { $_[0]++ }';
  67 mytest;
  68 BEGIN {++$ntests}
  69
  70 my $anon2;
  71 eval '$anon2 = sub : locked : method { $_[0]++ }';
  72 mytest;
  73 BEGIN {++$ntests}
  74
  75 my $anon3;
  76 eval '$anon3 = sub : method { $_[0]->[1] }';
  77 mytest;
  78 BEGIN {++$ntests}
  79
  80 eval 'sub e1 ($) : plugh ;';
  81 mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/;
  82 BEGIN {++$ntests}
  83
  84 eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
  85 mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /;
  86 BEGIN {++$ntests}
  87
  88 eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
  89 mytest qr/Unterminated attribute parameter in attribute list at/;
  90 BEGIN {++$ntests}
  91
  92 eval 'sub e4 ($) : plugh + xyzzy ;';
  93 mytest qr/Invalid separator character '[+]' in attribute list at/;
  94 BEGIN {++$ntests}
  95
  96 eval 'my main $x : = 0;';
  97 mytest;
  98 BEGIN {++$ntests}
  99
 100 eval 'my $x : = 0;';
 101 mytest;
 102 BEGIN {++$ntests}
 103
 104 eval 'my $x ;';
 105 mytest;
 106 BEGIN {++$ntests}
 107
 108 eval 'my ($x) : = 0;';
 109 mytest;
 110 BEGIN {++$ntests}
 111
 112 eval 'my ($x) ;';
 113 mytest;
 114 BEGIN {++$ntests}
 115
 116 eval 'my ($x) : ;';
 117 mytest;
 118 BEGIN {++$ntests}
 119
 120 eval 'my ($x,$y) : = 0;';
 121 mytest;
 122 BEGIN {++$ntests}
 123
 124 eval 'my ($x,$y) ;';
 125 mytest;
 126 BEGIN {++$ntests}
 127
 128 eval 'my ($x,$y) : ;';
 129 mytest;
 130 BEGIN {++$ntests}
 131
 132 eval 'my ($x,$y) : plugh;';
 133 mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/;
 134 BEGIN {++$ntests}
 135
 136 sub A::MODIFY_SCALAR_ATTRIBUTES { return }
 137 eval 'my A $x : plugh;';
 138 mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/;
 139 BEGIN {++$ntests}
 140
 141 eval 'my A $x : plugh plover;';
 142 mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
 143 BEGIN {++$ntests}
 144
 145 sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
 146 sub X::foo { 1 }
 147 *Y::bar = \&X::foo;
 148 *Y::bar = \&X::foo;     # second time for -w
 149 eval 'package Z; sub Y::bar : locked';
 150 mytest qr/^X at /;
 151 BEGIN {++$ntests}
 152
 153 my @attrs = eval 'attributes::get \&Y::bar';
 154 mytest '', "@attrs", "locked";
 155 BEGIN {++$ntests}
 156
 157 @attrs = eval 'attributes::get $anon1';
 158 mytest '', "@attrs", "locked method";
 159 BEGIN {++$ntests}
 160
 161 sub Z::DESTROY { }
 162 sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' }
 163 my $thunk = eval 'bless +sub : method locked { 1 }, "Z"';
 164 mytest '', ref($thunk), "Z";
 165 BEGIN {++$ntests}
 166
 167 @attrs = eval 'attributes::get $thunk';
 168 mytest '', "@attrs", "locked method Z";
 169 BEGIN {++$ntests}
 170
 171
 172 # Other tests should be added above this line
 173
 174 sub NTESTS () { $ntests }
 175
 176 exit $failed;