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 => 22;
  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 # Verify that the parsing of overriden keywords isn't messed up
  84 # by the indirect object notation
  85 {
  86     local $SIG{__WARN__} = sub {
  87         ::like( $_[0], qr/^ok overriden at/ );
  88     };
  89     BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; }
  90     package OverridenWarn;
  91     sub foo { "ok" }
  92     warn( OverridenWarn->foo() );
  93     warn OverridenWarn->foo();
  94 }
  95 BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; }
  96 {
  97     package OverridenPop;
  98     sub foo { [ "ok" ] }
  99     pop( OverridenPop->foo() );
 100     pop OverridenPop->foo();
 101 }
 102
 103 {
 104     eval {
 105         local *CORE::GLOBAL::require = sub {
 106             CORE::require($_[0]);
 107         };
 108         require 5;
 109         require Text::ParseWords;
 110     };
 111     is $@, '';
 112 }