t/op/inccode.t

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