1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8use strict; 9use Devel::SelfStubber; 10use File::Spec::Functions; 11 12my $runperl = "$^X \"-I../lib\""; 13$runperl =~ s|../lib|::lib:| if $^O eq 'MacOS'; 14 15# ensure correct output ordering for system() calls 16 17select STDERR; $| = 1; select STDOUT; $| = 1; 18 19print "1..12\n"; 20 21my @cleanup; 22 23END { 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 30my $inlib = "SSI-$$"; 31mkdir $inlib, 0777 or die $!; 32push @cleanup, $inlib; 33 34while (<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} 44close 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. 115my %wrong = ( Parent => 'Parent', Child => 'Parent' ); 116my %right = ( Parent => 'Parent', Child => 'Child' ); 117if ($^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} 122my @module = qw(Parent Child) 123; 124sub 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 134sub 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 143foreach my $module (@module) { 144 my $file = "$module--$$"; 145 push @cleanup, $file; 146 open FH, ">$file" or die $!; 147 print FH "use $module; 148print ${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 168my $lib="SSO-$$"; 169mkdir $lib, 0777 or die $!; 170push @cleanup, $lib; 171$Devel::SelfStubber::JUST_STUBS=0; 172 173undef $/; 174foreach 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} 192print "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 210system "$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. 214system "$runperl -w \"-I$lib\" \"-MEnd\" -e \"End::lime\""; 215 216# But check that the documentation after the __END__ survived. 217open FH, catfile(curdir(),$lib,"End.pm") or die $!; 218$_ = <FH>; 219close FH or die $!; 220 221if (/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 229package Parent; 230 231sub foo { 232 return __PACKAGE__; 233} 2341; 235__END__ 236################ Child.pm 237package Child; 238require Parent; 239@ISA = 'Parent'; 240use SelfLoader; 241 2421; 243__DATA__ 244sub foo { 245 return __PACKAGE__; 246} 247__END__ 248################ Proto.pm 249package Proto; 250use SelfLoader; 251 2521; 253__DATA__ 254sub bar ($$) { 255} 256################ Attribs.pm 257package Attribs; 258use SelfLoader; 259 2601; 261__DATA__ 262sub baz : locked { 263} 264sub lv : lvalue : method { 265 my $a; 266 \$a; 267} 268################ Data.pm 269package Data; 270use SelfLoader; 271 2721; 273__DATA__ 274sub ok { 275 print <DATA>; 276} 277__END__ DATA 278ok 10 279################ End.pm 280package End; 281use SelfLoader; 282 2831; 284__DATA__ 285sub lime { 286 print "ok 11\n"; 287} 288__END__ 289Did the documentation here survive? 290