ext/Devel-SelfStubber/t/Devel-SelfStubber.t

   1 #!./perl -w
   2
   3 use strict;
   4 use Devel::SelfStubber;
   5 use File::Spec::Functions;
   6
   7 my $runperl = $^X;
   8
   9 # ensure correct output ordering for system() calls
  10
  11 select STDERR; $| = 1; select STDOUT; $| = 1;
  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 $f = $1;
  31     my $file = catfile(curdir(),$inlib,$f);
  32     push @cleanup, $file;
  33     open FH, ">$file" or die $!;
  34   } else {
  35     print FH;
  36   }
  37 }
  38 close FH;
  39
  40 {
  41   my $file = "A-$$";
  42   push @cleanup, $file;
  43   open FH, ">$file" or die $!;
  44   select FH;
  45   Devel::SelfStubber->stub('xChild', $inlib);
  46   select STDOUT;
  47   print "ok 1\n";
  48   close FH or die $!;
  49
  50   open FH, $file or die $!;
  51   my @A = <FH>;
  52
  53   if (@A == 1 && $A[0] =~ /^\s*sub\s+xChild::foo\s*;\s*$/) {
  54     print "ok 2\n";
  55   } else {
  56     print "not ok 2\n";
  57     print "# $_" foreach (@A);
  58   }
  59 }
  60
  61 {
  62   my $file = "B-$$";
  63   push @cleanup, $file;
  64   open FH, ">$file" or die $!;
  65   select FH;
  66   Devel::SelfStubber->stub('Proto', $inlib);
  67   select STDOUT;
  68   print "ok 3\n"; # Checking that we did not die horribly.
  69   close FH or die $!;
  70
  71   open FH, $file or die $!;
  72   my @B = <FH>;
  73
  74   if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) {
  75     print "ok 4\n";
  76   } else {
  77     print "not ok 4\n";
  78     print "# $_" foreach (@B);
  79   }
  80
  81   close FH or die $!;
  82 }
  83
  84 {
  85   my $file = "C-$$";
  86   push @cleanup, $file;
  87   open FH, ">$file" or die $!;
  88   select FH;
  89   Devel::SelfStubber->stub('Attribs', $inlib);
  90   select STDOUT;
  91   print "ok 5\n"; # Checking that we did not die horribly.
  92   close FH or die $!;
  93
  94   open FH, $file or die $!;
  95   my @C = <FH>;
  96
  97   if (@C == 2 && $C[0] =~ /^\s*sub\s+Attribs::baz\s+:\s*locked\s*;\s*$/
  98       && $C[1] =~ /^\s*sub\s+Attribs::lv\s+:\s*lvalue\s*:\s*method\s*;\s*$/) {
  99     print "ok 6\n";
 100   } else {
 101     print "not ok 6\n";
 102     print "# $_" foreach (@C);
 103   }
 104
 105   close FH or die $!;
 106 }
 107
 108 # "wrong" and "right" may change if SelfLoader is changed.
 109 my %wrong = ( xParent => 'xParent', xChild => 'xParent' );
 110 my %right = ( xParent => 'xParent', xChild => 'xChild' );
 111 if ($^O eq 'VMS') {
 112     # extra line feeds for MBX IPC
 113     %wrong = ( xParent => "xParent\n", xChild => "xParent\n" );
 114     %right = ( xParent => "xParent\n", xChild => "xChild\n" );
 115 }
 116 my @module = qw(xParent xChild)
 117 ;
 118 sub fail {
 119   my ($left, $right) = @_;
 120   while (my ($key, $val) = each %$left) {
 121     # warn "$key $val $$right{$key}";
 122     return 1
 123       unless $val eq $$right{$key};
 124   }
 125   return;
 126 }
 127
 128 sub faildump {
 129   my ($expect, $got) = @_;
 130   foreach (sort keys %$expect) {
 131     print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n";
 132   }
 133 }
 134
 135 # Now test that the module tree behaves "wrongly" as expected
 136
 137 foreach my $module (@module) {
 138   my $file = "$module--$$";
 139   push @cleanup, $file;
 140   open FH, ">$file" or die $!;
 141   print FH "use $module;
 142 print ${module}->foo;
 143 ";
 144   close FH or die $!;
 145 }
 146
 147 {
 148   my %output;
 149   foreach my $module (@module) {
 150     print "# $runperl \"-I$inlib\" $module--$$\n";
 151     ($output{$module} = `$runperl "-I$inlib" $module--$$`)
 152       =~ s/\'s foo//;
 153   }
 154
 155   if (&fail (\%wrong, \%output)) {
 156     print "not ok 7\n", &faildump (\%wrong, \%output);
 157   } else {
 158     print "ok 7\n";
 159   }
 160 }
 161
 162 my $lib="SSO-$$";
 163 mkdir $lib, 0777 or die $!;
 164 push @cleanup, $lib;
 165 $Devel::SelfStubber::JUST_STUBS=0;
 166
 167 undef $/;
 168 foreach my $module (@module, 'Data', 'End') {
 169   my $file = catfile(curdir(),$lib,"$module.pm");
 170   my $fileo = catfile(curdir(),$inlib,"$module.pm");
 171   open FH, $fileo or die "Can't open $fileo: $!";
 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, catfile(curdir(),$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 ################ xParent.pm
 223 package xParent;
 224
 225 sub foo {
 226   return __PACKAGE__;
 227 }
 228 1;
 229 __END__
 230 ################ xChild.pm
 231 package xChild;
 232 require xParent;
 233 @ISA = 'xParent';
 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?