t/op/override.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '.';
   6     push @INC, '../lib';
   7 }
   8
   9 print "1..17\n";
  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 print "not " unless getlogin eq "kilroy";
  19 print "ok 1\n";
  20
  21 my $t = 42;
  22 BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
  23
  24 print "not " unless 45 == time + 3;
  25 print "ok 2\n";
  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 print "not " unless $r eq "Foo.pm";
  35 print "ok 3\n";
  36
  37 require Foo::Bar;
  38 print "not " unless $r eq join($dirsep, "Foo", "Bar.pm");
  39 print "ok 4\n";
  40
  41 require 'Foo';
  42 print "not " unless $r eq "Foo";
  43 print "ok 5\n";
  44
  45 require 5.6;
  46 print "not " unless $r eq "5.6";
  47 print "ok 6\n";
  48
  49 require v5.6;
  50 print "not " unless abs($r - 5.006) < 0.001 && $r eq "\x05\x06";
  51 print "ok 7\n";
  52
  53 eval "use Foo";
  54 print "not " unless $r eq "Foo.pm";
  55 print "ok 8\n";
  56
  57 eval "use Foo::Bar";
  58 print "not " unless $r eq join($dirsep, "Foo", "Bar.pm");
  59 print "ok 9\n";
  60
  61 eval "use 5.6";
  62 print "not " unless $r eq "5.6";
  63 print "ok 10\n";
  64
  65 # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
  66 {
  67     local(*CORE::GLOBAL::require);
  68     $r = '';
  69     eval "require NoNeXiSt;";
  70     print "not " if $r or $@ !~ /^Can't locate NoNeXiSt/i;
  71     print "ok 11\n";
  72 }
  73
  74 #
  75 # readline() has special behaviour too
  76 #
  77
  78 $r = 11;
  79 BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
  80 print <FH>      == 12 ? "ok 12\n" : "not ok 12\n";
  81 print <$fh>     == 13 ? "ok 13\n" : "not ok 13\n";
  82 my $pad_fh;
  83 print <$pad_fh> == 14 ? "ok 14\n" : "not ok 14\n";
  84
  85 # Non-global readline() override
  86 BEGIN { *Rgs::readline = sub (;*) { --$r }; }
  87 package Rgs;
  88 print <FH>      == 13 ? "ok 15\n" : "not ok 15\n";
  89 print <$fh>     == 12 ? "ok 16\n" : "not ok 16\n";
  90 print <$pad_fh> == 11 ? "ok 17\n" : "not ok 17\n";