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