END {print "not ok 1\n" unless $loaded;} use v5.6.0; use Attribute::Handlers; $loaded = 1; CHECK { $main::phase++ } ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not ", defined($_[2])?$_[2]:""]; } END { print "1..$::count\n"; print map "$_->[1]ok $_->[0] $_->[2]\n", sort {$a->[0]<=>$b->[0]} grep $_->[0], @::results } package Test; use warnings; no warnings 'redefine'; sub UNIVERSAL::Lastly :ATTR(INIT) { ::ok $_[4][0] && $main::phase, $_[4][1] } sub UNIVERSAL::Okay :ATTR(BEGIN) { ::ok $_[4][0] && (!$main::phase || !ref $_[1] && $_[1] eq 'LEXICAL'), $_[4][1]; } sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} } sub Dokay :ATTR(HASH) { ::ok @{$_[4]} } sub Dokay :ATTR(ARRAY) { ::ok @{$_[4]} } sub Dokay :ATTR(CODE) { ::ok @{$_[4]} } sub Vokay :ATTR(VAR) { ::ok @{$_[4]} } sub Aokay :ATTR(ANY) { ::ok @{$_[4]} } package main; use warnings; my $x1 :Lastly(1,41); my @x1 :Lastly(1=>42); my %x1 :Lastly(1,43); sub x1 :Lastly(1,44) {} my Test $x2 :Dokay(1,5); package Test; my $x3 :Dokay(1,6); my Test $x4 :Dokay(1,7); sub x3 :Dokay(1,8) {} my $y1 :Okay(1,9); my @y1 :Okay(1,10); my %y1 :Okay(1,11); sub y1 :Okay(1,12) {} my $y2 :Vokay(1,13); my @y2 :Vokay(1,14); my %y2 :Vokay(1,15); # BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or ::ok(1,16); # } my $z :Aokay(1,17); my @z :Aokay(1,18); my %z :Aokay(1,19); sub z :Aokay(1,20) {}; package DerTest; use base 'Test'; use warnings; my $x5 :Dokay(1,21); my Test $x6 :Dokay(1,22); sub x5 :Dokay(1,23); my $y3 :Okay(1,24); my @y3 :Okay(1,25); my %y3 :Okay(1,26); sub y3 :Okay(1,27) {} package Unrelated; my $x11 :Okay(1,1); my @x11 :Okay(1=>2); my %x11 :Okay(1,3); sub x11 :Okay(1,4) {} BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); } my Test $x8 :Dokay(1,29); eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30); package Tie::Loud; sub TIESCALAR { ::ok(1,31); bless {}, $_[0] } sub FETCH { ::ok(1,32); return 1 } sub STORE { ::ok(1,33); return 1 } package Tie::Noisy; sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] } sub FETCH { ::ok(1,35); return 1 } sub STORE { ::ok(1,36); return 1 } sub FETCHSIZE { 100 } package Tie::Row::dy; sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] } sub FETCH { ::ok(1,38); return 1 } sub STORE { ::ok(1,39); return 1 } package main; eval 'sub x7 :ATTR(SCALAR) :ATTR(CODE) {}' and ::ok(0,40) or ::ok(1,40); use Attribute::Handlers autotie => { Other::Loud => Tie::Loud, Noisy => Tie::Noisy, UNIVERSAL::Rowdy => Tie::Row::dy, }; my Other $loud : Loud; $loud++; my @noisy : Noisy(34); $noisy[0]++; my %rowdy : Rowdy(37,'this arg should be ignored'); $rowdy{key}++; # check that applying attributes to lexicals doesn't unduly worry # their refcounts my $out = "begin\n"; my $applied; sub UNIVERSAL::Dummy :ATTR { ++$applied }; sub Dummy::DESTROY { $out .= "bye\n" } { my $dummy; $dummy = bless {}, 'Dummy'; } ok( $out eq "begin\nbye\n", 45 ); { my $dummy : Dummy; $dummy = bless {}, 'Dummy'; } if($] < 5.008) { ok( 1, 46, " # skip lexicals are not runtime prior to 5.8"); } else { ok( $out eq "begin\nbye\nbye\n", 46); } # are lexical attributes reapplied correctly? sub dummy { my $dummy : Dummy; } $applied = 0; dummy(); dummy(); if($] < 5.008) { ok(1, 47, " # skip does not work with perl prior to 5.8"); } else { ok( $applied == 2, 47 ); } # 45-47 again, but for our variables $out = "begin\n"; { our $dummy; $dummy = bless {}, 'Dummy'; } ok( $out eq "begin\n", 48 ); { no warnings; our $dummy : Dummy; $dummy = bless {}, 'Dummy'; } ok( $out eq "begin\nbye\n", 49 ); undef $::dummy; ok( $out eq "begin\nbye\nbye\n", 50 ); # are lexical attributes reapplied correctly? sub dummy_our { no warnings; our $banjo : Dummy; } $applied = 0; dummy_our(); dummy_our(); ok( $applied == 0, 51 ); sub UNIVERSAL::Stooge :ATTR(END) {}; eval { local $SIG{__WARN__} = sub { die @_ }; my $groucho : Stooge; }; my $match = $@ =~ /^Won't be able to apply END handler/; if($] < 5.008) { ok(1,52 ,"# Skip, no difference between lexical handlers and normal handlers prior to 5.8"); } else { ok( $match, 52 ); }