t/op/inccode.t

   1 #!./perl -wT
   2
   3 # Tests for the coderef-in-@INC feature
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = '../lib';
   8 }
   9
  10 use File::Spec;
  11 use Test::More tests => 30;
  12
  13 my @tempfiles = ();
  14
  15 sub get_temp_fh {
  16     my $f = "DummyModule0000";
  17     1 while -e ++$f;
  18     push @tempfiles, $f;
  19     open my $fh, ">$f" or die "Can't create $f: $!";
  20     print $fh "package ".substr($_[0],0,-3)."; 1;";
  21     close $fh;
  22     open $fh, $f or die "Can't open $f: $!";
  23     return $fh;
  24 }
  25
  26 END { 1 while unlink @tempfiles }
  27
  28 sub get_addr {
  29     my $str = shift;
  30     $str =~ /(0x[0-9a-f]+)/i;
  31     return $1;
  32 }
  33
  34 sub fooinc {
  35     my ($self, $filename) = @_;
  36     if (substr($filename,0,3) eq 'Foo') {
  37         return get_temp_fh($filename);
  38     }
  39     else {
  40         return undef;
  41     }
  42 }
  43
  44 push @INC, \&fooinc;
  45
  46 ok( !eval { require Bar; 1 },      'Trying non-magic package' );
  47
  48 ok( eval { require Foo; 1 },       'require() magic via code ref'  );
  49 ok( exists $INC{'Foo.pm'},         '  %INC sees it' );
  50 is( get_addr($INC{'Foo.pm'}), get_addr(\&fooinc),
  51                                    '  key is correct in %INC' );
  52
  53 ok( eval "use Foo1; 1;",           'use()' );
  54 ok( exists $INC{'Foo1.pm'},        '  %INC sees it' );
  55 is( get_addr($INC{'Foo1.pm'}), get_addr(\&fooinc),
  56                                    '  key is correct in %INC' );
  57
  58 ok( eval { do 'Foo2.pl'; 1 },      'do()' );
  59 ok( exists $INC{'Foo2.pl'},        '  %INC sees it' );
  60 is( get_addr($INC{'Foo2.pl'}), get_addr(\&fooinc),
  61                                    '  key is correct in %INC' );
  62
  63 pop @INC;
  64
  65
  66 sub fooinc2 {
  67     my ($self, $filename) = @_;
  68     if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
  69         return get_temp_fh($filename);
  70     }
  71     else {
  72         return undef;
  73     }
  74 }
  75
  76 my $arrayref = [ \&fooinc2, 'Bar' ];
  77 push @INC, $arrayref;
  78
  79 ok( eval { require Foo; 1; },     'Originally loaded packages preserved' );
  80 ok( !eval { require Foo3; 1; },   'Original magic INC purged' );
  81
  82 ok( eval { require Bar; 1 },      'require() magic via array ref' );
  83 ok( exists $INC{'Bar.pm'},        '  %INC sees it' );
  84 is( get_addr($INC{'Bar.pm'}), get_addr($arrayref),
  85                                    '  key is correct in %INC' );
  86
  87 ok( eval "use Bar1; 1;",          'use()' );
  88 ok( exists $INC{'Bar1.pm'},       '  %INC sees it' );
  89 is( get_addr($INC{'Bar1.pm'}), get_addr($arrayref),
  90                                    '  key is correct in %INC' );
  91
  92 ok( eval { do 'Bar2.pl'; 1 },     'do()' );
  93 ok( exists $INC{'Bar2.pl'},       '  %INC sees it' );
  94 is( get_addr($INC{'Bar2.pl'}), get_addr($arrayref),
  95                                    '  key is correct in %INC' );
  96
  97 pop @INC;
  98
  99 sub FooLoader::INC {
 100     my ($self, $filename) = @_;
 101     if (substr($filename,0,4) eq 'Quux') {
 102         return get_temp_fh($filename);
 103     }
 104     else {
 105         return undef;
 106     }
 107 }
 108
 109 my $href = bless( {}, 'FooLoader' );
 110 push @INC, $href;
 111
 112 ok( eval { require Quux; 1 },      'require() magic via hash object' );
 113 ok( exists $INC{'Quux.pm'},        '  %INC sees it' );
 114 is( get_addr($INC{'Quux.pm'}), get_addr($href),
 115                                    '  key is correct in %INC' );
 116
 117 pop @INC;
 118
 119 my $aref = bless( [], 'FooLoader' );
 120 push @INC, $aref;
 121
 122 ok( eval { require Quux1; 1 },     'require() magic via array object' );
 123 ok( exists $INC{'Quux1.pm'},       '  %INC sees it' );
 124 is( get_addr($INC{'Quux1.pm'}), get_addr($aref),
 125                                    '  key is correct in %INC' );
 126
 127 pop @INC;
 128
 129 my $sref = bless( \(my $x = 1), 'FooLoader' );
 130 push @INC, $sref;
 131
 132 ok( eval { require Quux2; 1 },     'require() magic via scalar object' );
 133 ok( exists $INC{'Quux2.pm'},       '  %INC sees it' );
 134 is( get_addr($INC{'Quux2.pm'}), get_addr($sref),
 135                                    '  key is correct in %INC' );
 136
 137 pop @INC;