source: trunk/essentials/dev-lang/perl/t/op/override.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

plan tests => 21;

#
# This file tries to test builtin override using CORE::GLOBAL
#
my $dirsep = "/";

BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } }

is( getlogin, "kilroy" );

my $t = 42;
BEGIN { *CORE::GLOBAL::time = sub () { $t; } }

is( 45, time + 3 );

#
# require has special behaviour
#
my $r;
BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }

require Foo;
is( $r, "Foo.pm" );

require Foo::Bar;
is( $r, join($dirsep, "Foo", "Bar.pm") );

require 'Foo';
is( $r, "Foo" );

require 5.6;
is( $r, "5.6" );

require v5.6;
ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" );

eval "use Foo";
is( $r, "Foo.pm" );

eval "use Foo::Bar";
is( $r, join($dirsep, "Foo", "Bar.pm") );

eval "use 5.6";
is( $r, "5.6" );

# localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
{
    local(*CORE::GLOBAL::require);
    $r = '';
    eval "require NoNeXiSt;";
    ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) );
}

#
# readline() has special behaviour too
#

$r = 11;
BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
is( <FH>        , 12 );
is( <$fh>       , 13 );
my $pad_fh;
is( <$pad_fh>   , 14 );

# Non-global readline() override
BEGIN { *Rgs::readline = sub (;*) { --$r }; }
package Rgs;
::is( <FH>      , 13 );
::is( <$fh>     , 12 );
::is( <$pad_fh> , 11 );

# Verify that the parsing of overriden keywords isn't messed up
# by the indirect object notation
{
    local $SIG{__WARN__} = sub {
        ::like( $_[0], qr/^ok overriden at/ );
    };
    BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; }
    package OverridenWarn;
    sub foo { "ok" }
    warn( OverridenWarn->foo() );
    warn OverridenWarn->foo();
}
BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; }
package OverridenPop;
sub foo { [ "ok" ] }
pop( OverridenPop->foo() );
pop OverridenPop->foo();