t/op/override.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc(qw '../lib ../cpan/Text-ParseWords/lib');
   7     require Config; # load these before we mess with *CORE::GLOBAL::require
   8     require 'Config_heavy.pl'; # since runperl will need them
   9 }
  10
  11 plan tests => 37;
  12
  13 #
  14 # This file tries to test builtin override using CORE::GLOBAL
  15 #
  16 my $dirsep = "/";
  17
  18 BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } }
  19
  20 is( getlogin, "kilroy" );
  21
  22 my $t = 42;
  23 BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
  24
  25 is( 45, time + 3 );
  26
  27 #
  28 # require has special behaviour
  29 #
  30 my $r;
  31 BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }
  32
  33 require Foo;
  34 is( $r, "Foo.pm" );
  35
  36 require Foo::Bar;
  37 is( $r, join($dirsep, "Foo", "Bar.pm") );
  38
  39 require 'Foo';
  40 is( $r, "Foo" );
  41
  42 require 5.006;
  43 is( $r, "5.006" );
  44
  45 require v5.6;
  46 ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" );
  47
  48 eval "use Foo";
  49 is( $r, "Foo.pm" );
  50
  51 eval "use Foo::Bar";
  52 is( $r, join($dirsep, "Foo", "Bar.pm") );
  53
  54 {
  55     my @r;
  56     local *CORE::GLOBAL::require = sub { push @r, shift; 1; };
  57     eval "use 5.006";
  58     like( " @r ", qr " 5\.006 " );
  59 }
  60
  61 {
  62     local $_ = 'foo.pm';
  63     require;
  64     is( $r, 'foo.pm' );
  65 }
  66
  67 {
  68     BEGIN {
  69         # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-)
  70         CORE::require warnings;
  71         unimport warnings 'experimental::lexical_topic';
  72     }
  73     my $_ = 'bar.pm';
  74     require;
  75     is( $r, 'bar.pm' );
  76 }
  77
  78 # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
  79 {
  80     local(*CORE::GLOBAL::require);
  81     $r = '';
  82     eval "require NoNeXiSt;";
  83     ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) );
  84 }
  85
  86 #
  87 # readline() has special behaviour too
  88 #
  89
  90 $r = 11;
  91 BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
  92 is( <FH>        , 12 );
  93 is( <$fh>       , 13 );
  94 my $pad_fh;
  95 is( <$pad_fh>   , 14 );
  96 {
  97     my $buf = ''; $buf .= <FH>;
  98     is( $buf, 15, 'rcatline' );
  99 }
 100
 101 # Non-global readline() override
 102 BEGIN { *Rgs::readline = sub (;*) { --$r }; }
 103 {
 104     package Rgs;
 105     ::is( <FH>  , 14 );
 106     ::is( <$fh> , 13 );
 107     ::is( <$pad_fh>     , 12 );
 108     my $buf = ''; $buf .= <FH>;
 109     ::is( $buf, 11, 'rcatline' );
 110 }
 111
 112 # Global readpipe() override
 113 BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; }
 114 is( `rm`,           "rm 10", '``' );
 115 is( qx/cp/,         "cp 9", 'qx' );
 116
 117 # Non-global readpipe() override
 118 BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; }
 119 {
 120     package Rgs;
 121     ::is( `rm`,           "10 rm", '``' );
 122     ::is( qx/cp/,         "11 cp", 'qx' );
 123 }
 124
 125 # Verify that the parsing of overridden keywords isn't messed up
 126 # by the indirect object notation
 127 {
 128     local $SIG{__WARN__} = sub {
 129         ::like( $_[0], qr/^ok overriden at/ );
 130     };
 131     BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; }
 132     package OverridenWarn;
 133     sub foo { "ok" }
 134     warn( OverridenWarn->foo() );
 135     warn OverridenWarn->foo();
 136 }
 137 BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; }
 138 {
 139     package OverridenPop;
 140     sub foo { [ "ok" ] }
 141     pop( OverridenPop->foo() );
 142     pop OverridenPop->foo();
 143 }
 144
 145 {
 146     eval {
 147         local *CORE::GLOBAL::require = sub {
 148             CORE::require($_[0]);
 149         };
 150         require 5;
 151         require Text::ParseWords;
 152     };
 153     is $@, '';
 154 }
 155
 156 # Constant inlining should not countermand "use subs" overrides
 157 BEGIN { package other; *::caller = \&::caller }
 158 sub caller() { 42 }
 159 caller; # inline the constant
 160 is caller, 42, 'constant inlining does not undo "use subs" on keywords';
 161
 162 is runperl(prog => 'sub CORE::GLOBAL::do; do file; print qq-ok\n-'),
 163   "ok\n",
 164   'no crash with CORE::GLOBAL::do stub';
 165 is runperl(prog => 'sub CORE::GLOBAL::glob; glob; print qq-ok\n-'),
 166   "ok\n",
 167   'no crash with CORE::GLOBAL::glob stub';
 168 is runperl(prog => 'sub CORE::GLOBAL::require; require re; print qq-o\n-'),
 169   "o\n",
 170   'no crash with CORE::GLOBAL::require stub';
 171
 172 like runperl(prog => 'use constant foo=>1; '
 173                     .'BEGIN { *{q|CORE::GLOBAL::readpipe|} = \&{q|foo|};1}'
 174                     .'warn ``',
 175              stderr => 1),
 176      qr/Too many arguments/,
 177     '`` does not ignore &CORE::GLOBAL::readpipe aliased to a constant';
 178 like runperl(prog => 'use constant foo=>1; '
 179                     .'BEGIN { *{q|CORE::GLOBAL::readline|} = \&{q|foo|};1}'
 180                     .'warn <a>',
 181              stderr => 1),
 182      qr/Too many arguments/,
 183     '<> does not ignore &CORE::GLOBAL::readline aliased to a constant';
 184
 185 is runperl(prog => 'use constant t=>42; '
 186                   .'BEGIN { *{q|CORE::GLOBAL::time|} = \&{q|t|};1}'
 187                   .'print time, chr utf8::unicode_to_native(10)',
 188           stderr => 1),
 189    "42\n",
 190    'keywords respect global constant overrides';