| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 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 | |
| 11 | plan tests => 35; |
| 12 | |
| 13 | # |
| 14 | # This file tries to test builtin override using CORE::GLOBAL |
| 15 | # |
| 16 | my $dirsep = "/"; |
| 17 | |
| 18 | BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } } |
| 19 | |
| 20 | is( getlogin, "kilroy" ); |
| 21 | |
| 22 | my $t = 42; |
| 23 | BEGIN { *CORE::GLOBAL::time = sub () { $t; } } |
| 24 | |
| 25 | is( 45, time + 3 ); |
| 26 | |
| 27 | # |
| 28 | # require has special behaviour |
| 29 | # |
| 30 | my $r; |
| 31 | BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } |
| 32 | |
| 33 | require Foo; |
| 34 | is( $r, "Foo.pm" ); |
| 35 | |
| 36 | require Foo::Bar; |
| 37 | is( $r, join($dirsep, "Foo", "Bar.pm") ); |
| 38 | |
| 39 | require 'Foo'; |
| 40 | is( $r, "Foo" ); |
| 41 | |
| 42 | require 5.006; |
| 43 | is( $r, "5.006" ); |
| 44 | |
| 45 | require v5.6; |
| 46 | ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); |
| 47 | |
| 48 | eval "use Foo"; |
| 49 | is( $r, "Foo.pm" ); |
| 50 | |
| 51 | eval "use Foo::Bar"; |
| 52 | is( $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; |
| 91 | BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } |
| 92 | is( <FH> , 12 ); |
| 93 | is( <$fh> , 13 ); |
| 94 | my $pad_fh; |
| 95 | is( <$pad_fh> , 14 ); |
| 96 | |
| 97 | # Non-global readline() override |
| 98 | BEGIN { *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 |
| 107 | BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } |
| 108 | is( `rm`, "rm 10", '``' ); |
| 109 | is( qx/cp/, "cp 9", 'qx' ); |
| 110 | |
| 111 | # Non-global readpipe() override |
| 112 | BEGIN { *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 | } |
| 131 | BEGIN { *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 |
| 151 | BEGIN { package other; *::caller = \&::caller } |
| 152 | sub caller() { 42 } |
| 153 | caller; # inline the constant |
| 154 | is caller, 42, 'constant inlining does not undo "use subs" on keywords'; |
| 155 | |
| 156 | is runperl(prog => 'sub CORE::GLOBAL::do; do file; print qq-ok\n-'), |
| 157 | "ok\n", |
| 158 | 'no crash with CORE::GLOBAL::do stub'; |
| 159 | is runperl(prog => 'sub CORE::GLOBAL::glob; glob; print qq-ok\n-'), |
| 160 | "ok\n", |
| 161 | 'no crash with CORE::GLOBAL::glob stub'; |
| 162 | is runperl(prog => 'sub CORE::GLOBAL::require; require re; print qq-o\n-'), |
| 163 | "o\n", |
| 164 | 'no crash with CORE::GLOBAL::require stub'; |
| 165 | |
| 166 | like 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'; |
| 172 | like 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 | |
| 179 | is 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'; |