Commit | Line | Data |
7f4f6daf |
1 | #!./perl -w |
2 | |
7f4f6daf |
3 | use strict; |
4 | use Devel::SelfStubber; |
d5201bd2 |
5 | use File::Spec::Functions; |
7f4f6daf |
6 | |
f6c38fb9 |
7 | my $runperl = $^X; |
7f4f6daf |
8 | |
35dcc76e |
9 | # ensure correct output ordering for system() calls |
10 | |
11 | select STDERR; $| = 1; select STDOUT; $| = 1; |
12 | |
33235a50 |
13 | print "1..12\n"; |
7f4f6daf |
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+(.*)/) { |
d5201bd2 |
30 | my $f = $1; |
31 | my $file = catfile(curdir(),$inlib,$f); |
7f4f6daf |
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; |
c0529079 |
45 | Devel::SelfStubber->stub('xChild', $inlib); |
7f4f6daf |
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 | |
c0529079 |
53 | if (@A == 1 && $A[0] =~ /^\s*sub\s+xChild::foo\s*;\s*$/) { |
7f4f6daf |
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 | |
33235a50 |
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 | |
7f4f6daf |
108 | # "wrong" and "right" may change if SelfLoader is changed. |
c0529079 |
109 | my %wrong = ( xParent => 'xParent', xChild => 'xParent' ); |
110 | my %right = ( xParent => 'xParent', xChild => 'xChild' ); |
cbd00933 |
111 | if ($^O eq 'VMS') { |
112 | # extra line feeds for MBX IPC |
c0529079 |
113 | %wrong = ( xParent => "xParent\n", xChild => "xParent\n" ); |
114 | %right = ( xParent => "xParent\n", xChild => "xChild\n" ); |
cbd00933 |
115 | } |
c0529079 |
116 | my @module = qw(xParent xChild) |
7f4f6daf |
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) { |
ef61f41f |
150 | print "# $runperl \"-I$inlib\" $module--$$\n"; |
151 | ($output{$module} = `$runperl "-I$inlib" $module--$$`) |
7f4f6daf |
152 | =~ s/\'s foo//; |
153 | } |
154 | |
155 | if (&fail (\%wrong, \%output)) { |
33235a50 |
156 | print "not ok 7\n", &faildump (\%wrong, \%output); |
7f4f6daf |
157 | } else { |
33235a50 |
158 | print "ok 7\n"; |
7f4f6daf |
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 $/; |
33235a50 |
168 | foreach my $module (@module, 'Data', 'End') { |
d5201bd2 |
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: $!"; |
7f4f6daf |
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 | } |
33235a50 |
186 | print "ok 8\n"; |
7f4f6daf |
187 | |
188 | { |
189 | my %output; |
190 | foreach my $module (@module) { |
ef61f41f |
191 | print "# $runperl \"-I$lib\" $module--$$\n"; |
192 | ($output{$module} = `$runperl "-I$lib" $module--$$`) |
7f4f6daf |
193 | =~ s/\'s foo//; |
194 | } |
195 | |
196 | if (&fail (\%right, \%output)) { |
33235a50 |
197 | print "not ok 9\n", &faildump (\%right, \%output); |
7f4f6daf |
198 | } else { |
33235a50 |
199 | print "ok 9\n"; |
7f4f6daf |
200 | } |
201 | } |
202 | |
33235a50 |
203 | # Check that the DATA handle stays open |
efd6e025 |
204 | system "$runperl -w \"-I$lib\" \"-MData\" -e \"Data::ok\""; |
33235a50 |
205 | |
206 | # Possibly a pointless test as this doesn't really verify that it's been |
207 | # stubbed. |
efd6e025 |
208 | system "$runperl -w \"-I$lib\" \"-MEnd\" -e \"End::lime\""; |
33235a50 |
209 | |
210 | # But check that the documentation after the __END__ survived. |
d5201bd2 |
211 | open FH, catfile(curdir(),$lib,"End.pm") or die $!; |
33235a50 |
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 | |
7f4f6daf |
221 | __DATA__ |
c0529079 |
222 | ################ xParent.pm |
223 | package xParent; |
7f4f6daf |
224 | |
225 | sub foo { |
226 | return __PACKAGE__; |
227 | } |
228 | 1; |
229 | __END__ |
c0529079 |
230 | ################ xChild.pm |
231 | package xChild; |
232 | require xParent; |
233 | @ISA = 'xParent'; |
7f4f6daf |
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 | } |
33235a50 |
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? |