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