This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
60d772b6c9777ad116437acac049e378f7d590dd
[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 }
8
9 plan tests => 26;
10
11 #
12 # This file tries to test builtin override using CORE::GLOBAL
13 #
14 my $dirsep = "/";
15
16 BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } }
17
18 is( getlogin, "kilroy" );
19
20 my $t = 42;
21 BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
22
23 is( 45, time + 3 );
24
25 #
26 # require has special behaviour
27 #
28 my $r;
29 BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }
30
31 require Foo;
32 is( $r, "Foo.pm" );
33
34 require Foo::Bar;
35 is( $r, join($dirsep, "Foo", "Bar.pm") );
36
37 require 'Foo';
38 is( $r, "Foo" );
39
40 require 5.6;
41 is( $r, "5.6" );
42
43 require v5.6;
44 ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" );
45
46 eval "use Foo";
47 is( $r, "Foo.pm" );
48
49 eval "use Foo::Bar";
50 is( $r, join($dirsep, "Foo", "Bar.pm") );
51
52 eval "use 5.6";
53 is( $r, "5.6" );
54
55 # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
56 {
57     local(*CORE::GLOBAL::require);
58     $r = '';
59     eval "require NoNeXiSt;";
60     ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) );
61 }
62
63 #
64 # readline() has special behaviour too
65 #
66
67 $r = 11;
68 BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
69 is( <FH>        , 12 );
70 is( <$fh>       , 13 );
71 my $pad_fh;
72 is( <$pad_fh>   , 14 );
73
74 # Non-global readline() override
75 BEGIN { *Rgs::readline = sub (;*) { --$r }; }
76 {
77     package Rgs;
78     ::is( <FH>  , 13 );
79     ::is( <$fh> , 12 );
80     ::is( <$pad_fh>     , 11 );
81 }
82
83 # Global readpipe() override
84 BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; }
85 is( `rm`,           "rm 10", '``' );
86 is( qx/cp/,         "cp 9", 'qx' );
87
88 # Non-global readpipe() override
89 BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; }
90 {
91     package Rgs;
92     ::is( `rm`,           "10 rm", '``' );
93     ::is( qx/cp/,         "11 cp", 'qx' );
94 }
95
96 # Verify that the parsing of overriden keywords isn't messed up
97 # by the indirect object notation
98 {
99     local $SIG{__WARN__} = sub {
100         ::like( $_[0], qr/^ok overriden at/ );
101     };
102     BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; }
103     package OverridenWarn;
104     sub foo { "ok" }
105     warn( OverridenWarn->foo() );
106     warn OverridenWarn->foo();
107 }
108 BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; }
109 {
110     package OverridenPop;
111     sub foo { [ "ok" ] }
112     pop( OverridenPop->foo() );
113     pop OverridenPop->foo();
114 }
115
116 {
117     eval {
118         local *CORE::GLOBAL::require = sub {
119             CORE::require($_[0]);
120         };
121         require 5;
122         require Text::ParseWords;
123     };
124     is $@, '';
125 }