This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Stop gv_try_downgrade from anonymising referenced CVs
[perl5.git] / t / op / override.t
CommitLineData
2adfde11
GS
1#!./perl
2
3BEGIN {
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
952ad5fe 11plan tests => 33;
2adfde11
GS
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
30fe34ed 20is( getlogin, "kilroy" );
2adfde11
GS
21
22my $t = 42;
23BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
24
30fe34ed 25is( 45, time + 3 );
2adfde11
GS
26
27#
28# require has special behaviour
29#
30my $r;
31BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }
32
33require Foo;
30fe34ed 34is( $r, "Foo.pm" );
2adfde11
GS
35
36require Foo::Bar;
30fe34ed 37is( $r, join($dirsep, "Foo", "Bar.pm") );
2adfde11
GS
38
39require 'Foo';
30fe34ed 40is( $r, "Foo" );
2adfde11 41
88e9444c
NC
42require 5.006;
43is( $r, "5.006" );
2adfde11
GS
44
45require v5.6;
30fe34ed 46ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" );
2adfde11
GS
47
48eval "use Foo";
30fe34ed 49is( $r, "Foo.pm" );
2adfde11
GS
50
51eval "use Foo::Bar";
30fe34ed 52is( $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;
91BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
30fe34ed
RGS
92is( <FH> , 12 );
93is( <$fh> , 13 );
9b3023bc 94my $pad_fh;
30fe34ed 95is( <$pad_fh> , 14 );
9b3023bc
RGS
96
97# Non-global readline() override
98BEGIN { *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
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
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}
131BEGIN { *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
151BEGIN { package other; *::caller = \&::caller }
152sub caller() { 42 }
153caller; # inline the constant
154is caller, 42, 'constant inlining does not undo "use subs" on keywords';
069abe75
FC
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';
ae2c6838
FC
159is runperl(prog => 'sub CORE::GLOBAL::glob; glob; print qq-ok\n-'),
160 "ok\n",
161 'no crash with CORE::GLOBAL::glob stub';
fcea1f7a
FC
162is 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
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';