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