Commit | Line | Data |
---|---|---|
2adfde11 GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
30fe34ed RGS |
5 | @INC = '../lib'; |
6 | require './test.pl'; | |
069abe75 FC |
7 | require Config; # load these before we mess with *CORE::GLOBAL::require |
8 | require 'Config_heavy.pl'; # since runperl will need them | |
2adfde11 GS |
9 | } |
10 | ||
a93a1bfd | 11 | plan tests => 35; |
2adfde11 GS |
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 | ||
30fe34ed | 20 | is( getlogin, "kilroy" ); |
2adfde11 GS |
21 | |
22 | my $t = 42; | |
23 | BEGIN { *CORE::GLOBAL::time = sub () { $t; } } | |
24 | ||
30fe34ed | 25 | is( 45, time + 3 ); |
2adfde11 GS |
26 | |
27 | # | |
28 | # require has special behaviour | |
29 | # | |
30 | my $r; | |
31 | BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } | |
32 | ||
33 | require Foo; | |
30fe34ed | 34 | is( $r, "Foo.pm" ); |
2adfde11 GS |
35 | |
36 | require Foo::Bar; | |
30fe34ed | 37 | is( $r, join($dirsep, "Foo", "Bar.pm") ); |
2adfde11 GS |
38 | |
39 | require 'Foo'; | |
30fe34ed | 40 | is( $r, "Foo" ); |
2adfde11 | 41 | |
88e9444c NC |
42 | require 5.006; |
43 | is( $r, "5.006" ); | |
2adfde11 GS |
44 | |
45 | require v5.6; | |
30fe34ed | 46 | ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); |
2adfde11 GS |
47 | |
48 | eval "use Foo"; | |
30fe34ed | 49 | is( $r, "Foo.pm" ); |
2adfde11 GS |
50 | |
51 | eval "use Foo::Bar"; | |
30fe34ed | 52 | is( $r, join($dirsep, "Foo", "Bar.pm") ); |
2adfde11 | 53 | |
81bccfe4 | 54 | { |
7d69d4a6 FC |
55 | my @r; |
56 | local *CORE::GLOBAL::require = sub { push @r, shift; 1; }; | |
81bccfe4 | 57 | eval "use 5.006"; |
7d69d4a6 | 58 | like( " @r ", qr " 5\.006 " ); |
81bccfe4 | 59 | } |
b9f751c0 | 60 | |
7c864bb3 VP |
61 | { |
62 | local $_ = 'foo.pm'; | |
63 | require; | |
64 | is( $r, 'foo.pm' ); | |
65 | } | |
66 | ||
67 | { | |
703227f1 FC |
68 | BEGIN { |
69 | # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-) | |
70 | CORE::require warnings; | |
dcd695b6 | 71 | unimport warnings 'experimental::lexical_topic'; |
703227f1 | 72 | } |
7c864bb3 VP |
73 | my $_ = 'bar.pm'; |
74 | require; | |
75 | is( $r, 'bar.pm' ); | |
76 | } | |
77 | ||
b9f751c0 GS |
78 | # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo |
79 | { | |
80 | local(*CORE::GLOBAL::require); | |
81 | $r = ''; | |
82 | eval "require NoNeXiSt;"; | |
30fe34ed | 83 | ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) ); |
b9f751c0 | 84 | } |
9b3023bc RGS |
85 | |
86 | # | |
87 | # readline() has special behaviour too | |
88 | # | |
89 | ||
90 | $r = 11; | |
91 | BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } | |
30fe34ed RGS |
92 | is( <FH> , 12 ); |
93 | is( <$fh> , 13 ); | |
9b3023bc | 94 | my $pad_fh; |
30fe34ed | 95 | is( <$pad_fh> , 14 ); |
9b3023bc RGS |
96 | |
97 | # Non-global readline() override | |
98 | BEGIN { *Rgs::readline = sub (;*) { --$r }; } | |
149c1637 RGS |
99 | { |
100 | package Rgs; | |
101 | ::is( <FH> , 13 ); | |
102 | ::is( <$fh> , 12 ); | |
103 | ::is( <$pad_fh> , 11 ); | |
104 | } | |
30fe34ed | 105 | |
e3f73d4e RGS |
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 | ||
93f09d7b | 119 | # Verify that the parsing of overridden keywords isn't messed up |
30fe34ed RGS |
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" ) }; } | |
149c1637 RGS |
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 | } | |
70e5f2b5 FC |
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'; | |
069abe75 FC |
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'; | |
ae2c6838 FC |
159 | is runperl(prog => 'sub CORE::GLOBAL::glob; glob; print qq-ok\n-'), |
160 | "ok\n", | |
161 | 'no crash with CORE::GLOBAL::glob stub'; | |
fcea1f7a FC |
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'; | |
952ad5fe FC |
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'; | |
a93a1bfd FC |
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'; | |
60417971 FC |
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'; |