| 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 | } |