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 => 29;
  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.006;
  41 is( $r, "5.006" );
  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 {
  53     my @r;
  54     local *CORE::GLOBAL::require = sub { push @r, shift; 1; };
  55     eval "use 5.006";
  56     like( " @r ", qr " 5\.006 " );
  57 }
  58
  59 {
  60     local $_ = 'foo.pm';
  61     require;
  62     is( $r, 'foo.pm' );
  63 }
  64
  65 {
  66     BEGIN {
  67         # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-)
  68         CORE::require warnings;
  69         unimport warnings 'experimental::lexical_topic';
  70     }
  71     my $_ = 'bar.pm';
  72     require;
  73     is( $r, 'bar.pm' );
  74 }
  75
  76 # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
  77 {
  78     local(*CORE::GLOBAL::require);
  79     $r = '';
  80     eval "require NoNeXiSt;";
  81     ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) );
  82 }
  83
  84 #
  85 # readline() has special behaviour too
  86 #
  87
  88 $r = 11;
  89 BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
  90 is( <FH>        , 12 );
  91 is( <$fh>       , 13 );
  92 my $pad_fh;
  93 is( <$pad_fh>   , 14 );
  94
  95 # Non-global readline() override
  96 BEGIN { *Rgs::readline = sub (;*) { --$r }; }
  97 {
  98     package Rgs;
  99     ::is( <FH>  , 13 );
 100     ::is( <$fh> , 12 );
 101     ::is( <$pad_fh>     , 11 );
 102 }
 103
 104 # Global readpipe() override
 105 BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; }
 106 is( `rm`,           "rm 10", '``' );
 107 is( qx/cp/,         "cp 9", 'qx' );
 108
 109 # Non-global readpipe() override
 110 BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; }
 111 {
 112     package Rgs;
 113     ::is( `rm`,           "10 rm", '``' );
 114     ::is( qx/cp/,         "11 cp", 'qx' );
 115 }
 116
 117 # Verify that the parsing of overridden keywords isn't messed up
 118 # by the indirect object notation
 119 {
 120     local $SIG{__WARN__} = sub {
 121         ::like( $_[0], qr/^ok overriden at/ );
 122     };
 123     BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; }
 124     package OverridenWarn;
 125     sub foo { "ok" }
 126     warn( OverridenWarn->foo() );
 127     warn OverridenWarn->foo();
 128 }
 129 BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; }
 130 {
 131     package OverridenPop;
 132     sub foo { [ "ok" ] }
 133     pop( OverridenPop->foo() );
 134     pop OverridenPop->foo();
 135 }
 136
 137 {
 138     eval {
 139         local *CORE::GLOBAL::require = sub {
 140             CORE::require($_[0]);
 141         };
 142         require 5;
 143         require Text::ParseWords;
 144     };
 145     is $@, '';
 146 }
 147
 148 # Constant inlining should not countermand "use subs" overrides
 149 BEGIN { package other; *::caller = \&::caller }
 150 sub caller() { 42 }
 151 caller; # inline the constant
 152 is caller, 42, 'constant inlining does not undo "use subs" on keywords';