This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ce740eaf6cd482064dd3d7cbef278b2e17c052e3
[perl5.git] / t / op / override.t
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';