lib/Attribute/Handlers/t/multi.t

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