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