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