dist/Attribute-Handlers/t/multi.t

   1 #!perl
   2
   3 # This test file contains 57 tests.
   4 # You need to number them manually. Don't forget to update this line for the
   5 # next kind hacker.
   6
   7 END {print "not ok 1\n" unless $loaded;}
   8 use v5.6.0;
   9 use Attribute::Handlers;
  10 $loaded = 1;
  11
  12 CHECK { $main::phase++ }
  13
  14 ######################### End of black magic.
  15
  16 # Insert your test code below (better if it prints "ok 13"
  17 # (correspondingly "not ok 13") depending on the success of chunk 13
  18 # of the test code):
  19
  20 sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not ", defined($_[2])?$_[2]:""]; }
  21
  22 END { print "1..$::count\n";
  23       print map "$_->[1]ok $_->[0] $_->[2]\n",
  24                 sort {$a->[0]<=>$b->[0]}
  25                         grep $_->[0], @::results }
  26
  27 package Test;
  28 use warnings;
  29 no warnings 'redefine';
  30
  31 sub UNIVERSAL::Lastly :ATTR(INIT) { ::ok $_[4][0] && $main::phase, $_[4][1] }
  32
  33 sub UNIVERSAL::Okay :ATTR(BEGIN) {
  34 ::ok $_[4][0] && (!$main::phase || !ref $_[1] && $_[1] eq 'LEXICAL'), $_[4][1];
  35 }
  36
  37 sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} }
  38 sub Dokay :ATTR(HASH)   { ::ok @{$_[4]} }
  39 sub Dokay :ATTR(ARRAY)  { ::ok @{$_[4]} }
  40 sub Dokay :ATTR(CODE)   { ::ok @{$_[4]} }
  41
  42 sub Vokay :ATTR(VAR)    { ::ok @{$_[4]} }
  43
  44 sub Aokay :ATTR(ANY)    { ::ok @{$_[4]} }
  45
  46 package main;
  47 use warnings;
  48
  49 my $x1 :Lastly(1,41);
  50 my @x1 :Lastly(1=>42);
  51 my %x1 :Lastly(1,43);
  52 sub x1 :Lastly(1,44) {}
  53
  54 my Test $x2 :Dokay(1,5);
  55
  56 if ($] < 5.011) {
  57  ::ok(1, $_, '# skip : invalid before 5.11') for 55 .. 57;
  58 } else {
  59  my $c = $::count;
  60  eval '
  61   my Test @x2 :Dokay(1,55);
  62   my Test %x2 :Dokay(1,56);
  63  ';
  64  $c = $c + 2 - $::count;
  65  while ($c > 0) {
  66   ::ok(0, 57 - $c);
  67   --$c;
  68  }
  69  ::ok(!$@, 57);
  70 }
  71
  72 package Test;
  73 my $x3 :Dokay(1,6);
  74 my Test $x4 :Dokay(1,7);
  75 sub x3 :Dokay(1,8) {}
  76
  77 my $y1 :Okay(1,9);
  78 my @y1 :Okay(1,10);
  79 my %y1 :Okay(1,11);
  80 sub y1 :Okay(1,12) {}
  81
  82 my $y2 :Vokay(1,13);
  83 my @y2 :Vokay(1,14);
  84 my %y2 :Vokay(1,15);
  85 # BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or
  86 ::ok(1,16);
  87 # }
  88
  89 my $z :Aokay(1,17);
  90 my @z :Aokay(1,18);
  91 my %z :Aokay(1,19);
  92 sub z :Aokay(1,20) {};
  93
  94 package DerTest;
  95 use base 'Test';
  96 use warnings;
  97
  98 my $x5 :Dokay(1,21);
  99 my Test $x6 :Dokay(1,22);
 100 sub x5 :Dokay(1,23);
 101
 102 my $y3 :Okay(1,24);
 103 my @y3 :Okay(1,25);
 104 my %y3 :Okay(1,26);
 105 sub y3 :Okay(1,27) {}
 106
 107 package Unrelated;
 108
 109 my $x11 :Okay(1,1);
 110 my @x11 :Okay(1=>2);
 111 my %x11 :Okay(1,3);
 112 sub x11 :Okay(1,4) {}
 113
 114 BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); }
 115 my Test $x8 :Dokay(1,29);
 116 eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30);
 117
 118
 119 package Tie::Loud;
 120
 121 sub TIESCALAR { ::ok(1,31); bless {}, $_[0] }
 122 sub FETCH { ::ok(1,32); return 1 }
 123 sub STORE { ::ok(1,33); return 1 }
 124
 125 package Tie::Noisy;
 126
 127 sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] }
 128 sub FETCH { ::ok(1,35); return 1 }
 129 sub STORE { ::ok(1,36); return 1 }
 130 sub FETCHSIZE { 100 }
 131
 132 package Tie::Row::dy;
 133
 134 sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] }
 135 sub FETCH { ::ok(1,38); return 1 }
 136 sub STORE { ::ok(1,39); return 1 }
 137
 138 package main;
 139
 140 eval 'sub x7 :ATTR(SCALAR) :ATTR(CODE) {}' and ::ok(0,40) or ::ok(1,40);
 141
 142 use Attribute::Handlers autotie => {      Other::Loud => Tie::Loud,
 143                                                 Noisy => Tie::Noisy,
 144                                      UNIVERSAL::Rowdy => Tie::Row::dy,
 145                                    };
 146
 147 my Other $loud : Loud;
 148 $loud++;
 149
 150 my @noisy : Noisy(34);
 151 $noisy[0]++;
 152
 153 my %rowdy : Rowdy(37,'this arg should be ignored');
 154 $rowdy{key}++;
 155
 156
 157 # check that applying attributes to lexicals doesn't unduly worry
 158 # their refcounts
 159 my $out = "begin\n";
 160 my $applied;
 161 sub UNIVERSAL::Dummy :ATTR { ++$applied };
 162 sub Dummy::DESTROY { $out .= "bye\n" }
 163
 164 { my $dummy;          $dummy = bless {}, 'Dummy'; }
 165 ok( $out eq "begin\nbye\n", 45 );
 166
 167 { my $dummy : Dummy;  $dummy = bless {}, 'Dummy'; }
 168 if($] < 5.008) {
 169 ok( 1, 46, " # skip lexicals are not runtime prior to 5.8");
 170 } else {
 171 ok( $out eq "begin\nbye\nbye\n", 46);
 172 }
 173 # are lexical attributes reapplied correctly?
 174 sub dummy { my $dummy : Dummy; }
 175 $applied = 0;
 176 dummy(); dummy();
 177 if($] < 5.008) {
 178 ok(1, 47, " # skip does not work with perl prior to 5.8");
 179 } else {
 180 ok( $applied == 2, 47 );
 181 }
 182 # 45-47 again, but for our variables
 183 $out = "begin\n";
 184 { our $dummy;          $dummy = bless {}, 'Dummy'; }
 185 ok( $out eq "begin\n", 48 );
 186 { no warnings; our $dummy : Dummy;  $dummy = bless {}, 'Dummy'; }
 187 ok( $out eq "begin\nbye\n", 49 );
 188 undef $::dummy;
 189 ok( $out eq "begin\nbye\nbye\n", 50 );
 190
 191 # are lexical attributes reapplied correctly?
 192 sub dummy_our { no warnings; our $banjo : Dummy; }
 193 $applied = 0;
 194 dummy_our(); dummy_our();
 195 ok( $applied == 0, 51 );
 196
 197 sub UNIVERSAL::Stooge :ATTR(END) {};
 198 eval {
 199         local $SIG{__WARN__} = sub { die @_ };
 200         my $groucho : Stooge;
 201 };
 202 my $match = $@ =~ /^Won't be able to apply END handler/;
 203 if($] < 5.008) {
 204 ok(1,52 ,"# Skip, no difference between lexical handlers and normal handlers prior to 5.8");
 205 } else {
 206 ok( $match, 52 );
 207 }
 208
 209
 210 # The next two check for the phase invariance that Marcel spotted.
 211 # Subject: Attribute::Handlers phase variance
 212 # Message-Id: <54EDDB80-FD75-11D6-A18D-00039379E28A@noug.at>
 213
 214 my ($code_applied, $scalar_applied);
 215 sub Scotty :ATTR(CODE,BEGIN)   { $code_applied = $_[5] }
 216 {
 217 no warnings 'redefine';
 218 sub Scotty :ATTR(SCALAR,CHECK) { $scalar_applied = $_[5] }
 219 }
 220
 221 sub warp_coil :Scotty {}
 222 my $photon_torpedo :Scotty;
 223
 224 ok( $code_applied   eq 'BEGIN', 53, "# phase variance" );
 225 ok( $scalar_applied eq 'CHECK', 54 );