1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7 require Config; # load these before we mess with *CORE::GLOBAL::require 8 require 'Config_heavy.pl'; # since runperl will need them 9} 10 11plan tests => 35; 12 13# 14# This file tries to test builtin override using CORE::GLOBAL 15# 16my $dirsep = "/"; 17 18BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } } 19 20is( getlogin, "kilroy" ); 21 22my $t = 42; 23BEGIN { *CORE::GLOBAL::time = sub () { $t; } } 24 25is( 45, time + 3 ); 26 27# 28# require has special behaviour 29# 30my $r; 31BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } 32 33require Foo; 34is( $r, "Foo.pm" ); 35 36require Foo::Bar; 37is( $r, join($dirsep, "Foo", "Bar.pm") ); 38 39require 'Foo'; 40is( $r, "Foo" ); 41 42require 5.006; 43is( $r, "5.006" ); 44 45require v5.6; 46ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); 47 48eval "use Foo"; 49is( $r, "Foo.pm" ); 50 51eval "use Foo::Bar"; 52is( $r, join($dirsep, "Foo", "Bar.pm") ); 53 54{ 55 my @r; 56 local *CORE::GLOBAL::require = sub { push @r, shift; 1; }; 57 eval "use 5.006"; 58 like( " @r ", qr " 5\.006 " ); 59} 60 61{ 62 local $_ = 'foo.pm'; 63 require; 64 is( $r, 'foo.pm' ); 65} 66 67{ 68 BEGIN { 69 # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-) 70 CORE::require warnings; 71 unimport warnings 'experimental::lexical_topic'; 72 } 73 my $_ = 'bar.pm'; 74 require; 75 is( $r, 'bar.pm' ); 76} 77 78# localizing *CORE::GLOBAL::foo should revert to finding CORE::foo 79{ 80 local(*CORE::GLOBAL::require); 81 $r = ''; 82 eval "require NoNeXiSt;"; 83 ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) ); 84} 85 86# 87# readline() has special behaviour too 88# 89 90$r = 11; 91BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } 92is( <FH> , 12 ); 93is( <$fh> , 13 ); 94my $pad_fh; 95is( <$pad_fh> , 14 ); 96 97# Non-global readline() override 98BEGIN { *Rgs::readline = sub (;*) { --$r }; } 99{ 100 package Rgs; 101 ::is( <FH> , 13 ); 102 ::is( <$fh> , 12 ); 103 ::is( <$pad_fh> , 11 ); 104} 105 106# Global readpipe() override 107BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } 108is( `rm`, "rm 10", '``' ); 109is( qx/cp/, "cp 9", 'qx' ); 110 111# Non-global readpipe() override 112BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; } 113{ 114 package Rgs; 115 ::is( `rm`, "10 rm", '``' ); 116 ::is( qx/cp/, "11 cp", 'qx' ); 117} 118 119# Verify that the parsing of overridden keywords isn't messed up 120# by the indirect object notation 121{ 122 local $SIG{__WARN__} = sub { 123 ::like( $_[0], qr/^ok overriden at/ ); 124 }; 125 BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; } 126 package OverridenWarn; 127 sub foo { "ok" } 128 warn( OverridenWarn->foo() ); 129 warn OverridenWarn->foo(); 130} 131BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; } 132{ 133 package OverridenPop; 134 sub foo { [ "ok" ] } 135 pop( OverridenPop->foo() ); 136 pop OverridenPop->foo(); 137} 138 139{ 140 eval { 141 local *CORE::GLOBAL::require = sub { 142 CORE::require($_[0]); 143 }; 144 require 5; 145 require Text::ParseWords; 146 }; 147 is $@, ''; 148} 149 150# Constant inlining should not countermand "use subs" overrides 151BEGIN { package other; *::caller = \&::caller } 152sub caller() { 42 } 153caller; # inline the constant 154is caller, 42, 'constant inlining does not undo "use subs" on keywords'; 155 156is runperl(prog => 'sub CORE::GLOBAL::do; do file; print qq-ok\n-'), 157 "ok\n", 158 'no crash with CORE::GLOBAL::do stub'; 159is runperl(prog => 'sub CORE::GLOBAL::glob; glob; print qq-ok\n-'), 160 "ok\n", 161 'no crash with CORE::GLOBAL::glob stub'; 162is runperl(prog => 'sub CORE::GLOBAL::require; require re; print qq-o\n-'), 163 "o\n", 164 'no crash with CORE::GLOBAL::require stub'; 165 166like runperl(prog => 'use constant foo=>1; ' 167 .'BEGIN { *{q|CORE::GLOBAL::readpipe|} = \&{q|foo|};1}' 168 .'warn ``', 169 stderr => 1), 170 qr/Too many arguments/, 171 '`` does not ignore &CORE::GLOBAL::readpipe aliased to a constant'; 172like runperl(prog => 'use constant foo=>1; ' 173 .'BEGIN { *{q|CORE::GLOBAL::readline|} = \&{q|foo|};1}' 174 .'warn <a>', 175 stderr => 1), 176 qr/Too many arguments/, 177 '<> does not ignore &CORE::GLOBAL::readline aliased to a constant'; 178 179is runperl(prog => 'use constant t=>42; ' 180 .'BEGIN { *{q|CORE::GLOBAL::time|} = \&{q|t|};1}' 181 .'print time, chr 10', 182 stderr => 1), 183 "42\n", 184 'keywords respect global constant overrides'; 185