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