1*f2a19305Safresh1#!perl 2*f2a19305Safresh1 3*f2a19305Safresh1BEGIN { 4*f2a19305Safresh1 chdir 't' if -d 't'; 5*f2a19305Safresh1 require './test.pl'; 6*f2a19305Safresh1 set_up_inc( qw(../lib) ); 7*f2a19305Safresh1} 8*f2a19305Safresh1 9*f2a19305Safresh1use strict; 10*f2a19305Safresh1use warnings; 11*f2a19305Safresh1 12*f2a19305Safresh1plan(tests => 14); 13*f2a19305Safresh1 14*f2a19305Safresh1{ 15*f2a19305Safresh1 fresh_perl_like( 16*f2a19305Safresh1 '${^HOOK}{require__before} = "x";', 17*f2a19305Safresh1 qr!\$\{\^HOOK\}\{require__before\} may only be a CODE reference or undef!, 18*f2a19305Safresh1 { }, 19*f2a19305Safresh1 '%{^HOOK} forbids non code refs (string)'); 20*f2a19305Safresh1} 21*f2a19305Safresh1{ 22*f2a19305Safresh1 fresh_perl_like( 23*f2a19305Safresh1 '${^HOOK}{require__before} = [];', 24*f2a19305Safresh1 qr!\$\{\^HOOK\}\{require__before\} may only be a CODE reference or undef!, 25*f2a19305Safresh1 { }, 26*f2a19305Safresh1 '%{^HOOK} forbids non code refs (array)'); 27*f2a19305Safresh1} 28*f2a19305Safresh1{ 29*f2a19305Safresh1 fresh_perl_like( 30*f2a19305Safresh1 '${^HOOK}{require__before} = sub { die "Not allowed to load $_[0]" }; require Frobnitz;', 31*f2a19305Safresh1 qr!Not allowed to load Frobnitz\.pm!, 32*f2a19305Safresh1 { }, 33*f2a19305Safresh1 '${^HOOK}{require__before} exceptions stop require'); 34*f2a19305Safresh1} 35*f2a19305Safresh1{ 36*f2a19305Safresh1 fresh_perl_is( 37*f2a19305Safresh1 'use lib "./lib/caller"; '. 38*f2a19305Safresh1 '${^HOOK}{require__before} = '. 39*f2a19305Safresh1 ' sub { my ($name) = @_; warn "before $name"; ' . 40*f2a19305Safresh1 ' return sub { warn "after $name" } }; ' . 41*f2a19305Safresh1 'require Apack;', 42*f2a19305Safresh1 <<'EOF_WANT', 43*f2a19305Safresh1before Apack.pm at - line 1. 44*f2a19305Safresh1before Bpack.pm at - line 1. 45*f2a19305Safresh1before Cpack.pm at - line 1. 46*f2a19305Safresh1after Cpack.pm at - line 1. 47*f2a19305Safresh1after Bpack.pm at - line 1. 48*f2a19305Safresh1after Apack.pm at - line 1. 49*f2a19305Safresh1EOF_WANT 50*f2a19305Safresh1 { }, 51*f2a19305Safresh1 '${^HOOK}{require__before} with post action works as expected with t/lib/caller/Apack'); 52*f2a19305Safresh1} 53*f2a19305Safresh1{ 54*f2a19305Safresh1 fresh_perl_is( 55*f2a19305Safresh1 'use lib "./lib/caller"; '. 56*f2a19305Safresh1 '${^HOOK}{require__before} = '. 57*f2a19305Safresh1 ' sub { $_[0] = "Apack.pm" if $_[0] eq "Cycle.pm";'. 58*f2a19305Safresh1 ' my ($name) = @_; warn "before $name"; ' . 59*f2a19305Safresh1 ' return sub { warn "after $name" } }; ' . 60*f2a19305Safresh1 'require Cycle;', 61*f2a19305Safresh1 <<'EOF_WANT', 62*f2a19305Safresh1before Apack.pm at - line 1. 63*f2a19305Safresh1before Bpack.pm at - line 1. 64*f2a19305Safresh1before Cpack.pm at - line 1. 65*f2a19305Safresh1after Cpack.pm at - line 1. 66*f2a19305Safresh1after Bpack.pm at - line 1. 67*f2a19305Safresh1after Apack.pm at - line 1. 68*f2a19305Safresh1EOF_WANT 69*f2a19305Safresh1 { }, 70*f2a19305Safresh1 '${^HOOK}{require__before} with filename rewrite works as expected (Cycle.pm -> Apack.pm)'); 71*f2a19305Safresh1} 72*f2a19305Safresh1{ 73*f2a19305Safresh1 fresh_perl_is( 74*f2a19305Safresh1 'use lib "./lib/caller"; '. 75*f2a19305Safresh1 '${^HOOK}{require__before} = '. 76*f2a19305Safresh1 ' sub { my ($name) = @_; my $n = ++$::counter; warn "before $name ($n)"; ' . 77*f2a19305Safresh1 ' return sub { warn "after $name ($n)" } }; ' . 78*f2a19305Safresh1 'require Cycle;', 79*f2a19305Safresh1 <<'EOF_WANT', 80*f2a19305Safresh1before Cycle.pm (1) at - line 1. 81*f2a19305Safresh1before Bicycle.pm (2) at - line 1. 82*f2a19305Safresh1before Tricycle.pm (3) at - line 1. 83*f2a19305Safresh1before Cycle.pm (4) at - line 1. 84*f2a19305Safresh1after Cycle.pm (4) at - line 1. 85*f2a19305Safresh1after Tricycle.pm (3) at - line 1. 86*f2a19305Safresh1after Bicycle.pm (2) at - line 1. 87*f2a19305Safresh1after Cycle.pm (1) at - line 1. 88*f2a19305Safresh1EOF_WANT 89*f2a19305Safresh1 { }, 90*f2a19305Safresh1 '${^HOOK}{require__before} with post action with state work as expected with t/lib/caller/Cycle'); 91*f2a19305Safresh1} 92*f2a19305Safresh1{ 93*f2a19305Safresh1 fresh_perl_is( 94*f2a19305Safresh1 'use lib "./lib/caller"; my @seen;'. 95*f2a19305Safresh1 '${^HOOK}{require__before} = '. 96*f2a19305Safresh1 ' sub { die "Cycle detected: @seen $_[0]\n" if grep $_ eq $_[0], @seen; push @seen,$_[0]; ' . 97*f2a19305Safresh1 ' return sub { pop @seen } }; ' . 98*f2a19305Safresh1 'require Cycle;', 99*f2a19305Safresh1 <<'EOF_WANT', 100*f2a19305Safresh1Cycle detected: Cycle.pm Bicycle.pm Tricycle.pm Cycle.pm 101*f2a19305Safresh1Compilation failed in require at lib/caller/Bicycle.pm line 1. 102*f2a19305Safresh1Compilation failed in require at lib/caller/Cycle.pm line 1. 103*f2a19305Safresh1Compilation failed in require at - line 1. 104*f2a19305Safresh1EOF_WANT 105*f2a19305Safresh1 { }, 106*f2a19305Safresh1 '${^HOOK}{require__before} with post action with state work as expected with t/lib/caller/Cycle'); 107*f2a19305Safresh1} 108*f2a19305Safresh1{ 109*f2a19305Safresh1 fresh_perl_is( 110*f2a19305Safresh1 'use lib "./lib/caller"; '. 111*f2a19305Safresh1 '${^HOOK}{require__before} = '. 112*f2a19305Safresh1 ' sub { my ($before_name) = @_; warn "before $before_name"; ' . 113*f2a19305Safresh1 ' return sub { my ($after_name) = @_; warn "after $after_name" } }; ' . 114*f2a19305Safresh1 'require Apack;', 115*f2a19305Safresh1 <<'EOF_WANT', 116*f2a19305Safresh1before Apack.pm at - line 1. 117*f2a19305Safresh1before Bpack.pm at - line 1. 118*f2a19305Safresh1before Cpack.pm at - line 1. 119*f2a19305Safresh1after Cpack.pm at - line 1. 120*f2a19305Safresh1after Bpack.pm at - line 1. 121*f2a19305Safresh1after Apack.pm at - line 1. 122*f2a19305Safresh1EOF_WANT 123*f2a19305Safresh1 { }, 124*f2a19305Safresh1 '${^HOOK}{require__before} with post action and name arg works as expected'); 125*f2a19305Safresh1} 126*f2a19305Safresh1{ 127*f2a19305Safresh1 fresh_perl_is( 128*f2a19305Safresh1 'use lib "./lib/caller"; '. 129*f2a19305Safresh1 '${^HOOK}{require__before} = '. 130*f2a19305Safresh1 ' sub { my ($name) = @_; warn "before $name" };' . 131*f2a19305Safresh1 'require Apack;', 132*f2a19305Safresh1 <<'EOF_WANT', 133*f2a19305Safresh1before Apack.pm at - line 1. 134*f2a19305Safresh1before Bpack.pm at - line 1. 135*f2a19305Safresh1before Cpack.pm at - line 1. 136*f2a19305Safresh1EOF_WANT 137*f2a19305Safresh1 { }, 138*f2a19305Safresh1 '${^HOOK}{require__before} with no post action works as expected with t/lib/caller/Apack'); 139*f2a19305Safresh1} 140*f2a19305Safresh1{ 141*f2a19305Safresh1 fresh_perl_is( 142*f2a19305Safresh1 'use lib "./lib/caller"; '. 143*f2a19305Safresh1 '${^HOOK}{require__after} = '. 144*f2a19305Safresh1 ' sub { my ($name) = @_; warn "after $name" };' . 145*f2a19305Safresh1 'require Apack;', 146*f2a19305Safresh1 <<'EOF_WANT', 147*f2a19305Safresh1after Cpack.pm at - line 1. 148*f2a19305Safresh1after Bpack.pm at - line 1. 149*f2a19305Safresh1after Apack.pm at - line 1. 150*f2a19305Safresh1EOF_WANT 151*f2a19305Safresh1 { }, 152*f2a19305Safresh1 '${^HOOK}{require__after} works as expected with t/lib/caller/Apack'); 153*f2a19305Safresh1} 154*f2a19305Safresh1{ 155*f2a19305Safresh1 fresh_perl_is( 156*f2a19305Safresh1 'use lib "./lib/caller"; '. 157*f2a19305Safresh1 '%{^HOOK} = ( require__before => sub { print "before: $_[0]\n" }, 158*f2a19305Safresh1 require__after => sub { print "after: $_[0]\n" } ); 159*f2a19305Safresh1 { local %{^HOOK}; require Apack; } 160*f2a19305Safresh1 print "done\n";', 161*f2a19305Safresh1 "done\n", 162*f2a19305Safresh1 { }, 163*f2a19305Safresh1 'local %{^HOOK} works to clear hooks.' 164*f2a19305Safresh1 ); 165*f2a19305Safresh1} 166*f2a19305Safresh1{ 167*f2a19305Safresh1 fresh_perl_is( 168*f2a19305Safresh1 'use lib "./lib/caller"; '. 169*f2a19305Safresh1 '%{^HOOK} = ( require__before => sub { print "before: $_[0]\n" }, 170*f2a19305Safresh1 require__after => sub { print "after: $_[0]\n" } ); 171*f2a19305Safresh1 { local %{^HOOK}; require Cycle; } 172*f2a19305Safresh1 require Apack;', 173*f2a19305Safresh1 <<'EOF_WANT', 174*f2a19305Safresh1before: Apack.pm 175*f2a19305Safresh1before: Bpack.pm 176*f2a19305Safresh1before: Cpack.pm 177*f2a19305Safresh1after: Cpack.pm 178*f2a19305Safresh1after: Bpack.pm 179*f2a19305Safresh1after: Apack.pm 180*f2a19305Safresh1EOF_WANT 181*f2a19305Safresh1 { }, 182*f2a19305Safresh1 'local %{^HOOK} works to clear and restore hooks.' 183*f2a19305Safresh1 ); 184*f2a19305Safresh1} 185*f2a19305Safresh1{ 186*f2a19305Safresh1 fresh_perl_is( 187*f2a19305Safresh1 'use lib "./lib/caller"; '. 188*f2a19305Safresh1 '%{^HOOK} = ( require__before => sub { print "before: $_[0]\n" } ); 189*f2a19305Safresh1 %{^HOOK} = ( require__after => sub { print "after: $_[0]\n" } ); 190*f2a19305Safresh1 require Apack;', 191*f2a19305Safresh1 <<'EOF_WANT', 192*f2a19305Safresh1after: Cpack.pm 193*f2a19305Safresh1after: Bpack.pm 194*f2a19305Safresh1after: Apack.pm 195*f2a19305Safresh1EOF_WANT 196*f2a19305Safresh1 { }, 197*f2a19305Safresh1 '%{^HOOK} = (...); works as expected (part 1)' 198*f2a19305Safresh1 ); 199*f2a19305Safresh1} 200*f2a19305Safresh1 201*f2a19305Safresh1{ 202*f2a19305Safresh1 fresh_perl_is( 203*f2a19305Safresh1 'use lib "./lib/caller"; '. 204*f2a19305Safresh1 '%{^HOOK} = ( require__after => sub { print "after: $_[0]\n" } ); 205*f2a19305Safresh1 %{^HOOK} = ( require__before => sub { print "before: $_[0]\n" } ); 206*f2a19305Safresh1 require Apack;', 207*f2a19305Safresh1 <<'EOF_WANT', 208*f2a19305Safresh1before: Apack.pm 209*f2a19305Safresh1before: Bpack.pm 210*f2a19305Safresh1before: Cpack.pm 211*f2a19305Safresh1EOF_WANT 212*f2a19305Safresh1 { }, 213*f2a19305Safresh1 '%{^HOOK} = (...); works as expected (part 2)' 214*f2a19305Safresh1 ); 215*f2a19305Safresh1} 216