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