t/lib/selfstubber.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use strict;
   9 use Devel::SelfStubber;
  10
  11 my $runperl = "$^X \"-I../lib\"";
  12
  13 print "1..7\n";
  14
  15 my @cleanup;
  16
  17 END {
  18   foreach my $file (reverse @cleanup) {
  19     unlink $file or warn "unlink $file failed: $!" while -f $file;
  20     rmdir $file or warn "rmdir $file failed: $!" if -d $file;
  21   }
  22 }
  23
  24 my $inlib = "SSI-$$";
  25 mkdir $inlib, 0777 or die $!;
  26 push @cleanup, $inlib;
  27
  28 while (<DATA>) {
  29   if (/^\#{16,}\s+(.*)/) {
  30     my $file = "$inlib/$1";
  31     push @cleanup, $file;
  32     open FH, ">$file" or die $!;
  33   } else {
  34     print FH;
  35   }
  36 }
  37 close FH;
  38
  39 {
  40   my $file = "A-$$";
  41   push @cleanup, $file;
  42   open FH, ">$file" or die $!;
  43   select FH;
  44   Devel::SelfStubber->stub('Child', $inlib);
  45   select STDOUT;
  46   print "ok 1\n";
  47   close FH or die $!;
  48
  49   open FH, $file or die $!;
  50   my @A = <FH>;
  51
  52   if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) {
  53     print "ok 2\n";
  54   } else {
  55     print "not ok 2\n";
  56     print "# $_" foreach (@A);
  57   }
  58 }
  59
  60 {
  61   my $file = "B-$$";
  62   push @cleanup, $file;
  63   open FH, ">$file" or die $!;
  64   select FH;
  65   Devel::SelfStubber->stub('Proto', $inlib);
  66   select STDOUT;
  67   print "ok 3\n"; # Checking that we did not die horribly.
  68   close FH or die $!;
  69
  70   open FH, $file or die $!;
  71   my @B = <FH>;
  72
  73   if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) {
  74     print "ok 4\n";
  75   } else {
  76     print "not ok 4\n";
  77     print "# $_" foreach (@B);
  78   }
  79
  80   close FH or die $!;
  81 }
  82
  83 # "wrong" and "right" may change if SelfLoader is changed.
  84 my %wrong = ( Parent => 'Parent', Child => 'Parent' );
  85 my %right = ( Parent => 'Parent', Child => 'Child' );
  86 my @module = qw(Parent Child)
  87 ;
  88 sub fail {
  89   my ($left, $right) = @_;
  90   while (my ($key, $val) = each %$left) {
  91     # warn "$key $val $$right{$key}";
  92     return 1
  93       unless $val eq $$right{$key};
  94   }
  95   return;
  96 }
  97
  98 sub faildump {
  99   my ($expect, $got) = @_;
 100   foreach (sort keys %$expect) {
 101     print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n";
 102   }
 103 }
 104
 105 # Now test that the module tree behaves "wrongly" as expected
 106
 107 foreach my $module (@module) {
 108   my $file = "$module--$$";
 109   push @cleanup, $file;
 110   open FH, ">$file" or die $!;
 111   print FH "use $module;
 112 print ${module}->foo;
 113 ";
 114   close FH or die $!;
 115 }
 116
 117 {
 118   my %output;
 119   foreach my $module (@module) {
 120     print "# $runperl \"-I$inlib\" $module--$$\n";
 121     ($output{$module} = `$runperl "-I$inlib" $module--$$`)
 122       =~ s/\'s foo//;
 123   }
 124
 125   if (&fail (\%wrong, \%output)) {
 126     print "not ok 5\n", &faildump (\%wrong, \%output);
 127   } else {
 128     print "ok 5\n";
 129   }
 130 }
 131
 132 my $lib="SSO-$$";
 133 mkdir $lib, 0777 or die $!;
 134 push @cleanup, $lib;
 135 $Devel::SelfStubber::JUST_STUBS=0;
 136
 137 undef $/;
 138 foreach my $module (@module) {
 139   my $file = "$lib/$module.pm";
 140   open FH, "$inlib/$module.pm" or die $!;
 141   my $contents = <FH>;
 142   close FH or die $!;
 143   push @cleanup, $file;
 144   open FH, ">$file" or die $!;
 145   select FH;
 146   if ($contents =~ /__DATA__/) {
 147     # This will die for any module with no  __DATA__
 148     Devel::SelfStubber->stub($module, $inlib);
 149   } else {
 150     print $contents;
 151   }
 152   select STDOUT;
 153   close FH or die $!;
 154 }
 155 print "ok 6\n";
 156
 157 {
 158   my %output;
 159   foreach my $module (@module) {
 160     print "# $runperl \"-I$lib\" $module--$$\n";
 161     ($output{$module} = `$runperl "-I$lib" $module--$$`)
 162       =~ s/\'s foo//;
 163   }
 164
 165   if (&fail (\%right, \%output)) {
 166     print "not ok 7\n", &faildump (\%right, \%output);
 167   } else {
 168     print "ok 7\n";
 169   }
 170 }
 171
 172 __DATA__
 173 ################ Parent.pm
 174 package Parent;
 175
 176 sub foo {
 177   return __PACKAGE__;
 178 }
 179 1;
 180 __END__
 181 ################ Child.pm
 182 package Child;
 183 require Parent;
 184 @ISA = 'Parent';
 185 use SelfLoader;
 186
 187 1;
 188 __DATA__
 189 sub foo {
 190   return __PACKAGE__;
 191 }
 192 __END__
 193 ################ Proto.pm
 194 package Proto;
 195 use SelfLoader;
 196
 197 1;
 198 __DATA__
 199 sub bar ($$) {
 200 }