Commit | Line | Data |
7f4f6daf |
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 | |
ef61f41f |
11 | my $runperl = "$^X \"-I../lib\""; |
7f4f6daf |
12 | |
35dcc76e |
13 | # ensure correct output ordering for system() calls |
14 | |
15 | select STDERR; $| = 1; select STDOUT; $| = 1; |
16 | |
33235a50 |
17 | print "1..12\n"; |
7f4f6daf |
18 | |
19 | my @cleanup; |
20 | |
21 | END { |
22 | foreach my $file (reverse @cleanup) { |
23 | unlink $file or warn "unlink $file failed: $!" while -f $file; |
24 | rmdir $file or warn "rmdir $file failed: $!" if -d $file; |
25 | } |
26 | } |
27 | |
28 | my $inlib = "SSI-$$"; |
29 | mkdir $inlib, 0777 or die $!; |
30 | push @cleanup, $inlib; |
31 | |
32 | while (<DATA>) { |
33 | if (/^\#{16,}\s+(.*)/) { |
34 | my $file = "$inlib/$1"; |
35 | push @cleanup, $file; |
36 | open FH, ">$file" or die $!; |
37 | } else { |
38 | print FH; |
39 | } |
40 | } |
41 | close FH; |
42 | |
43 | { |
44 | my $file = "A-$$"; |
45 | push @cleanup, $file; |
46 | open FH, ">$file" or die $!; |
47 | select FH; |
48 | Devel::SelfStubber->stub('Child', $inlib); |
49 | select STDOUT; |
50 | print "ok 1\n"; |
51 | close FH or die $!; |
52 | |
53 | open FH, $file or die $!; |
54 | my @A = <FH>; |
55 | |
56 | if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) { |
57 | print "ok 2\n"; |
58 | } else { |
59 | print "not ok 2\n"; |
60 | print "# $_" foreach (@A); |
61 | } |
62 | } |
63 | |
64 | { |
65 | my $file = "B-$$"; |
66 | push @cleanup, $file; |
67 | open FH, ">$file" or die $!; |
68 | select FH; |
69 | Devel::SelfStubber->stub('Proto', $inlib); |
70 | select STDOUT; |
71 | print "ok 3\n"; # Checking that we did not die horribly. |
72 | close FH or die $!; |
73 | |
74 | open FH, $file or die $!; |
75 | my @B = <FH>; |
76 | |
77 | if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) { |
78 | print "ok 4\n"; |
79 | } else { |
80 | print "not ok 4\n"; |
81 | print "# $_" foreach (@B); |
82 | } |
83 | |
84 | close FH or die $!; |
85 | } |
86 | |
33235a50 |
87 | { |
88 | my $file = "C-$$"; |
89 | push @cleanup, $file; |
90 | open FH, ">$file" or die $!; |
91 | select FH; |
92 | Devel::SelfStubber->stub('Attribs', $inlib); |
93 | select STDOUT; |
94 | print "ok 5\n"; # Checking that we did not die horribly. |
95 | close FH or die $!; |
96 | |
97 | open FH, $file or die $!; |
98 | my @C = <FH>; |
99 | |
100 | if (@C == 2 && $C[0] =~ /^\s*sub\s+Attribs::baz\s+:\s*locked\s*;\s*$/ |
101 | && $C[1] =~ /^\s*sub\s+Attribs::lv\s+:\s*lvalue\s*:\s*method\s*;\s*$/) { |
102 | print "ok 6\n"; |
103 | } else { |
104 | print "not ok 6\n"; |
105 | print "# $_" foreach (@C); |
106 | } |
107 | |
108 | close FH or die $!; |
109 | } |
110 | |
7f4f6daf |
111 | # "wrong" and "right" may change if SelfLoader is changed. |
112 | my %wrong = ( Parent => 'Parent', Child => 'Parent' ); |
113 | my %right = ( Parent => 'Parent', Child => 'Child' ); |
cbd00933 |
114 | if ($^O eq 'VMS') { |
115 | # extra line feeds for MBX IPC |
116 | %wrong = ( Parent => "Parent\n", Child => "Parent\n" ); |
117 | %right = ( Parent => "Parent\n", Child => "Child\n" ); |
118 | } |
7f4f6daf |
119 | my @module = qw(Parent Child) |
120 | ; |
121 | sub fail { |
122 | my ($left, $right) = @_; |
123 | while (my ($key, $val) = each %$left) { |
124 | # warn "$key $val $$right{$key}"; |
125 | return 1 |
126 | unless $val eq $$right{$key}; |
127 | } |
128 | return; |
129 | } |
130 | |
131 | sub faildump { |
132 | my ($expect, $got) = @_; |
133 | foreach (sort keys %$expect) { |
134 | print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n"; |
135 | } |
136 | } |
137 | |
138 | # Now test that the module tree behaves "wrongly" as expected |
139 | |
140 | foreach my $module (@module) { |
141 | my $file = "$module--$$"; |
142 | push @cleanup, $file; |
143 | open FH, ">$file" or die $!; |
144 | print FH "use $module; |
145 | print ${module}->foo; |
146 | "; |
147 | close FH or die $!; |
148 | } |
149 | |
150 | { |
151 | my %output; |
152 | foreach my $module (@module) { |
ef61f41f |
153 | print "# $runperl \"-I$inlib\" $module--$$\n"; |
154 | ($output{$module} = `$runperl "-I$inlib" $module--$$`) |
7f4f6daf |
155 | =~ s/\'s foo//; |
156 | } |
157 | |
158 | if (&fail (\%wrong, \%output)) { |
33235a50 |
159 | print "not ok 7\n", &faildump (\%wrong, \%output); |
7f4f6daf |
160 | } else { |
33235a50 |
161 | print "ok 7\n"; |
7f4f6daf |
162 | } |
163 | } |
164 | |
165 | my $lib="SSO-$$"; |
166 | mkdir $lib, 0777 or die $!; |
167 | push @cleanup, $lib; |
168 | $Devel::SelfStubber::JUST_STUBS=0; |
169 | |
170 | undef $/; |
33235a50 |
171 | foreach my $module (@module, 'Data', 'End') { |
7f4f6daf |
172 | my $file = "$lib/$module.pm"; |
173 | open FH, "$inlib/$module.pm" or die $!; |
174 | my $contents = <FH>; |
175 | close FH or die $!; |
176 | push @cleanup, $file; |
177 | open FH, ">$file" or die $!; |
178 | select FH; |
179 | if ($contents =~ /__DATA__/) { |
180 | # This will die for any module with no __DATA__ |
181 | Devel::SelfStubber->stub($module, $inlib); |
182 | } else { |
183 | print $contents; |
184 | } |
185 | select STDOUT; |
186 | close FH or die $!; |
187 | } |
33235a50 |
188 | print "ok 8\n"; |
7f4f6daf |
189 | |
190 | { |
191 | my %output; |
192 | foreach my $module (@module) { |
ef61f41f |
193 | print "# $runperl \"-I$lib\" $module--$$\n"; |
194 | ($output{$module} = `$runperl "-I$lib" $module--$$`) |
7f4f6daf |
195 | =~ s/\'s foo//; |
196 | } |
197 | |
198 | if (&fail (\%right, \%output)) { |
33235a50 |
199 | print "not ok 9\n", &faildump (\%right, \%output); |
7f4f6daf |
200 | } else { |
33235a50 |
201 | print "ok 9\n"; |
7f4f6daf |
202 | } |
203 | } |
204 | |
33235a50 |
205 | # Check that the DATA handle stays open |
206 | system "$runperl -w \"-I$lib\" -MData -e Data::ok"; |
207 | |
208 | # Possibly a pointless test as this doesn't really verify that it's been |
209 | # stubbed. |
210 | system "$runperl -w \"-I$lib\" -MEnd -e End::lime"; |
211 | |
212 | # But check that the documentation after the __END__ survived. |
213 | open FH, "$lib/End.pm" or die $!; |
214 | $_ = <FH>; |
215 | close FH or die $!; |
216 | |
217 | if (/Did the documentation here survive\?/) { |
218 | print "ok 12\n"; |
219 | } else { |
220 | print "not ok 12 # information after an __END__ token seems to be lost\n"; |
221 | } |
222 | |
7f4f6daf |
223 | __DATA__ |
224 | ################ Parent.pm |
225 | package Parent; |
226 | |
227 | sub foo { |
228 | return __PACKAGE__; |
229 | } |
230 | 1; |
231 | __END__ |
232 | ################ Child.pm |
233 | package Child; |
234 | require Parent; |
235 | @ISA = 'Parent'; |
236 | use SelfLoader; |
237 | |
238 | 1; |
239 | __DATA__ |
240 | sub foo { |
241 | return __PACKAGE__; |
242 | } |
243 | __END__ |
244 | ################ Proto.pm |
245 | package Proto; |
246 | use SelfLoader; |
247 | |
248 | 1; |
249 | __DATA__ |
250 | sub bar ($$) { |
251 | } |
33235a50 |
252 | ################ Attribs.pm |
253 | package Attribs; |
254 | use SelfLoader; |
255 | |
256 | 1; |
257 | __DATA__ |
258 | sub baz : locked { |
259 | } |
260 | sub lv : lvalue : method { |
261 | my $a; |
262 | \$a; |
263 | } |
264 | ################ Data.pm |
265 | package Data; |
266 | use SelfLoader; |
267 | |
268 | 1; |
269 | __DATA__ |
270 | sub ok { |
271 | print <DATA>; |
272 | } |
273 | __END__ DATA |
274 | ok 10 |
275 | ################ End.pm |
276 | package End; |
277 | use SelfLoader; |
278 | |
279 | 1; |
280 | __DATA__ |
281 | sub lime { |
282 | print "ok 11\n"; |
283 | } |
284 | __END__ |
285 | Did the documentation here survive? |