lib/Devel/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 use File::Spec::Functions;
  11
  12 my $runperl = "$^X \"-I../lib\"";
  13 $runperl =~ s|../lib|::lib:| if $^O eq 'MacOS';
  14
  15 # ensure correct output ordering for system() calls
  16
  17 select STDERR; $| = 1; select STDOUT; $| = 1;
  18
  19 print "1..12\n";
  20
  21 my @cleanup;
  22
  23 END {
  24   foreach my $file (reverse @cleanup) {
  25     unlink $file or warn "unlink $file failed: $!" while -f $file;
  26     rmdir $file or warn "rmdir $file failed: $!" if -d $file;
  27   }
  28 }
  29
  30 my $inlib = "SSI-$$";
  31 mkdir $inlib, 0777 or die $!;
  32 push @cleanup, $inlib;
  33
  34 while (<DATA>) {
  35   if (/^\#{16,}\s+(.*)/) {
  36     my $f = $1;
  37     my $file = catfile(curdir(),$inlib,$f);
  38     push @cleanup, $file;
  39     open FH, ">$file" or die $!;
  40   } else {
  41     print FH;
  42   }
  43 }
  44 close FH;
  45
  46 {
  47   my $file = "A-$$";
  48   push @cleanup, $file;
  49   open FH, ">$file" or die $!;
  50   select FH;
  51   Devel::SelfStubber->stub('Child', $inlib);
  52   select STDOUT;
  53   print "ok 1\n";
  54   close FH or die $!;
  55
  56   open FH, $file or die $!;
  57   my @A = <FH>;
  58
  59   if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) {
  60     print "ok 2\n";
  61   } else {
  62     print "not ok 2\n";
  63     print "# $_" foreach (@A);
  64   }
  65 }
  66
  67 {
  68   my $file = "B-$$";
  69   push @cleanup, $file;
  70   open FH, ">$file" or die $!;
  71   select FH;
  72   Devel::SelfStubber->stub('Proto', $inlib);
  73   select STDOUT;
  74   print "ok 3\n"; # Checking that we did not die horribly.
  75   close FH or die $!;
  76
  77   open FH, $file or die $!;
  78   my @B = <FH>;
  79
  80   if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) {
  81     print "ok 4\n";
  82   } else {
  83     print "not ok 4\n";
  84     print "# $_" foreach (@B);
  85   }
  86
  87   close FH or die $!;
  88 }
  89
  90 {
  91   my $file = "C-$$";
  92   push @cleanup, $file;
  93   open FH, ">$file" or die $!;
  94   select FH;
  95   Devel::SelfStubber->stub('Attribs', $inlib);
  96   select STDOUT;
  97   print "ok 5\n"; # Checking that we did not die horribly.
  98   close FH or die $!;
  99
 100   open FH, $file or die $!;
 101   my @C = <FH>;
 102
 103   if (@C == 2 && $C[0] =~ /^\s*sub\s+Attribs::baz\s+:\s*locked\s*;\s*$/
 104       && $C[1] =~ /^\s*sub\s+Attribs::lv\s+:\s*lvalue\s*:\s*method\s*;\s*$/) {
 105     print "ok 6\n";
 106   } else {
 107     print "not ok 6\n";
 108     print "# $_" foreach (@C);
 109   }
 110
 111   close FH or die $!;
 112 }
 113
 114 # "wrong" and "right" may change if SelfLoader is changed.
 115 my %wrong = ( Parent => 'Parent', Child => 'Parent' );
 116 my %right = ( Parent => 'Parent', Child => 'Child' );
 117 if ($^O eq 'VMS') {
 118     # extra line feeds for MBX IPC
 119     %wrong = ( Parent => "Parent\n", Child => "Parent\n" );
 120     %right = ( Parent => "Parent\n", Child => "Child\n" );
 121 }
 122 my @module = qw(Parent Child)
 123 ;
 124 sub fail {
 125   my ($left, $right) = @_;
 126   while (my ($key, $val) = each %$left) {
 127     # warn "$key $val $$right{$key}";
 128     return 1
 129       unless $val eq $$right{$key};
 130   }
 131   return;
 132 }
 133
 134 sub faildump {
 135   my ($expect, $got) = @_;
 136   foreach (sort keys %$expect) {
 137     print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n";
 138   }
 139 }
 140
 141 # Now test that the module tree behaves "wrongly" as expected
 142
 143 foreach my $module (@module) {
 144   my $file = "$module--$$";
 145   push @cleanup, $file;
 146   open FH, ">$file" or die $!;
 147   print FH "use $module;
 148 print ${module}->foo;
 149 ";
 150   close FH or die $!;
 151 }
 152
 153 {
 154   my %output;
 155   foreach my $module (@module) {
 156     print "# $runperl \"-I$inlib\" $module--$$\n";
 157     ($output{$module} = `$runperl "-I$inlib" $module--$$`)
 158       =~ s/\'s foo//;
 159   }
 160
 161   if (&fail (\%wrong, \%output)) {
 162     print "not ok 7\n", &faildump (\%wrong, \%output);
 163   } else {
 164     print "ok 7\n";
 165   }
 166 }
 167
 168 my $lib="SSO-$$";
 169 mkdir $lib, 0777 or die $!;
 170 push @cleanup, $lib;
 171 $Devel::SelfStubber::JUST_STUBS=0;
 172
 173 undef $/;
 174 foreach my $module (@module, 'Data', 'End') {
 175   my $file = catfile(curdir(),$lib,"$module.pm");
 176   my $fileo = catfile(curdir(),$inlib,"$module.pm");
 177   open FH, $fileo or die "Can't open $fileo: $!";
 178   my $contents = <FH>;
 179   close FH or die $!;
 180   push @cleanup, $file;
 181   open FH, ">$file" or die $!;
 182   select FH;
 183   if ($contents =~ /__DATA__/) {
 184     # This will die for any module with no  __DATA__
 185     Devel::SelfStubber->stub($module, $inlib);
 186   } else {
 187     print $contents;
 188   }
 189   select STDOUT;
 190   close FH or die $!;
 191 }
 192 print "ok 8\n";
 193
 194 {
 195   my %output;
 196   foreach my $module (@module) {
 197     print "# $runperl \"-I$lib\" $module--$$\n";
 198     ($output{$module} = `$runperl "-I$lib" $module--$$`)
 199       =~ s/\'s foo//;
 200   }
 201
 202   if (&fail (\%right, \%output)) {
 203     print "not ok 9\n", &faildump (\%right, \%output);
 204   } else {
 205     print "ok 9\n";
 206   }
 207 }
 208
 209 # Check that the DATA handle stays open
 210 system "$runperl -w \"-I$lib\" \"-MData\" -e \"Data::ok\"";
 211
 212 # Possibly a pointless test as this doesn't really verify that it's been
 213 # stubbed.
 214 system "$runperl -w \"-I$lib\" \"-MEnd\" -e \"End::lime\"";
 215
 216 # But check that the documentation after the __END__ survived.
 217 open FH, catfile(curdir(),$lib,"End.pm") or die $!;
 218 $_ = <FH>;
 219 close FH or die $!;
 220
 221 if (/Did the documentation here survive\?/) {
 222   print "ok 12\n";
 223 } else {
 224   print "not ok 12 # information after an __END__ token seems to be lost\n";
 225 }
 226
 227 __DATA__
 228 ################ Parent.pm
 229 package Parent;
 230
 231 sub foo {
 232   return __PACKAGE__;
 233 }
 234 1;
 235 __END__
 236 ################ Child.pm
 237 package Child;
 238 require Parent;
 239 @ISA = 'Parent';
 240 use SelfLoader;
 241
 242 1;
 243 __DATA__
 244 sub foo {
 245   return __PACKAGE__;
 246 }
 247 __END__
 248 ################ Proto.pm
 249 package Proto;
 250 use SelfLoader;
 251
 252 1;
 253 __DATA__
 254 sub bar ($$) {
 255 }
 256 ################ Attribs.pm
 257 package Attribs;
 258 use SelfLoader;
 259
 260 1;
 261 __DATA__
 262 sub baz : locked {
 263 }
 264 sub lv : lvalue : method {
 265   my $a;
 266   \$a;
 267 }
 268 ################ Data.pm
 269 package Data;
 270 use SelfLoader;
 271
 272 1;
 273 __DATA__
 274 sub ok {
 275   print <DATA>;
 276 }
 277 __END__ DATA
 278 ok 10
 279 ################ End.pm
 280 package End;
 281 use SelfLoader;
 282
 283 1;
 284 __DATA__
 285 sub lime {
 286   print "ok 11\n";
 287 }
 288 __END__
 289 Did the documentation here survive?