Commit | Line | Data |
---|---|---|
2adfde11 GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
30fe34ed RGS |
5 | @INC = '../lib'; |
6 | require './test.pl'; | |
2adfde11 GS |
7 | } |
8 | ||
7c864bb3 | 9 | plan tests => 28; |
2adfde11 GS |
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 | ||
30fe34ed | 18 | is( getlogin, "kilroy" ); |
2adfde11 GS |
19 | |
20 | my $t = 42; | |
21 | BEGIN { *CORE::GLOBAL::time = sub () { $t; } } | |
22 | ||
30fe34ed | 23 | is( 45, time + 3 ); |
2adfde11 GS |
24 | |
25 | # | |
26 | # require has special behaviour | |
27 | # | |
28 | my $r; | |
29 | BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } | |
30 | ||
31 | require Foo; | |
30fe34ed | 32 | is( $r, "Foo.pm" ); |
2adfde11 GS |
33 | |
34 | require Foo::Bar; | |
30fe34ed | 35 | is( $r, join($dirsep, "Foo", "Bar.pm") ); |
2adfde11 GS |
36 | |
37 | require 'Foo'; | |
30fe34ed | 38 | is( $r, "Foo" ); |
2adfde11 | 39 | |
88e9444c NC |
40 | require 5.006; |
41 | is( $r, "5.006" ); | |
2adfde11 GS |
42 | |
43 | require v5.6; | |
30fe34ed | 44 | ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); |
2adfde11 GS |
45 | |
46 | eval "use Foo"; | |
30fe34ed | 47 | is( $r, "Foo.pm" ); |
2adfde11 GS |
48 | |
49 | eval "use Foo::Bar"; | |
30fe34ed | 50 | is( $r, join($dirsep, "Foo", "Bar.pm") ); |
2adfde11 | 51 | |
7d69d4a6 | 52 | # use VERSION also loads feature.pm. |
81bccfe4 | 53 | { |
7d69d4a6 FC |
54 | my @r; |
55 | local *CORE::GLOBAL::require = sub { push @r, shift; 1; }; | |
81bccfe4 | 56 | eval "use 5.006"; |
7d69d4a6 | 57 | like( " @r ", qr " 5\.006 " ); |
81bccfe4 | 58 | } |
b9f751c0 | 59 | |
7c864bb3 VP |
60 | { |
61 | local $_ = 'foo.pm'; | |
62 | require; | |
63 | is( $r, 'foo.pm' ); | |
64 | } | |
65 | ||
66 | { | |
67 | my $_ = 'bar.pm'; | |
68 | require; | |
69 | is( $r, 'bar.pm' ); | |
70 | } | |
71 | ||
b9f751c0 GS |
72 | # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo |
73 | { | |
74 | local(*CORE::GLOBAL::require); | |
75 | $r = ''; | |
76 | eval "require NoNeXiSt;"; | |
30fe34ed | 77 | ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) ); |
b9f751c0 | 78 | } |
9b3023bc RGS |
79 | |
80 | # | |
81 | # readline() has special behaviour too | |
82 | # | |
83 | ||
84 | $r = 11; | |
85 | BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } | |
30fe34ed RGS |
86 | is( <FH> , 12 ); |
87 | is( <$fh> , 13 ); | |
9b3023bc | 88 | my $pad_fh; |
30fe34ed | 89 | is( <$pad_fh> , 14 ); |
9b3023bc RGS |
90 | |
91 | # Non-global readline() override | |
92 | BEGIN { *Rgs::readline = sub (;*) { --$r }; } | |
149c1637 RGS |
93 | { |
94 | package Rgs; | |
95 | ::is( <FH> , 13 ); | |
96 | ::is( <$fh> , 12 ); | |
97 | ::is( <$pad_fh> , 11 ); | |
98 | } | |
30fe34ed | 99 | |
e3f73d4e RGS |
100 | # Global readpipe() override |
101 | BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } | |
102 | is( `rm`, "rm 10", '``' ); | |
103 | is( qx/cp/, "cp 9", 'qx' ); | |
104 | ||
105 | # Non-global readpipe() override | |
106 | BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; } | |
107 | { | |
108 | package Rgs; | |
109 | ::is( `rm`, "10 rm", '``' ); | |
110 | ::is( qx/cp/, "11 cp", 'qx' ); | |
111 | } | |
112 | ||
93f09d7b | 113 | # Verify that the parsing of overridden keywords isn't messed up |
30fe34ed RGS |
114 | # by the indirect object notation |
115 | { | |
116 | local $SIG{__WARN__} = sub { | |
117 | ::like( $_[0], qr/^ok overriden at/ ); | |
118 | }; | |
119 | BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; } | |
120 | package OverridenWarn; | |
121 | sub foo { "ok" } | |
122 | warn( OverridenWarn->foo() ); | |
123 | warn OverridenWarn->foo(); | |
124 | } | |
125 | BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; } | |
149c1637 RGS |
126 | { |
127 | package OverridenPop; | |
128 | sub foo { [ "ok" ] } | |
129 | pop( OverridenPop->foo() ); | |
130 | pop OverridenPop->foo(); | |
131 | } | |
132 | ||
133 | { | |
134 | eval { | |
135 | local *CORE::GLOBAL::require = sub { | |
136 | CORE::require($_[0]); | |
137 | }; | |
138 | require 5; | |
139 | require Text::ParseWords; | |
140 | }; | |
141 | is $@, ''; | |
142 | } |