test for Devel::SelfStubber
[p5sagit/p5-mst-13.2.git] / t / lib / selfstubber.t
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
11 my $runperl = './perl';
12
13 print "1..7\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 $file = "$inlib/$1";
31     push @cleanup, $file;
32     open FH, ">$file" or die $!;
33   } else {
34     print FH;
35   }
36 }
37 close FH;
38
39 {
40   my $file = "A-$$";
41   push @cleanup, $file;
42   open FH, ">$file" or die $!;
43   select FH;
44   Devel::SelfStubber->stub('Child', $inlib);
45   select STDOUT;
46   print "ok 1\n";
47   close FH or die $!;
48
49   open FH, $file or die $!;
50   my @A = <FH>;
51
52   if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) {
53     print "ok 2\n";
54   } else {
55     print "not ok 2\n";
56     print "# $_" foreach (@A);
57   }
58 }
59
60 {
61   my $file = "B-$$";
62   push @cleanup, $file;
63   open FH, ">$file" or die $!;
64   select FH;
65   Devel::SelfStubber->stub('Proto', $inlib);
66   select STDOUT;
67   print "ok 3\n"; # Checking that we did not die horribly.
68   close FH or die $!;
69
70   open FH, $file or die $!;
71   my @B = <FH>;
72
73   if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) {
74     print "ok 4\n";
75   } else {
76     print "not ok 4\n";
77     print "# $_" foreach (@B);
78   }
79
80   close FH or die $!;
81 }
82
83 # "wrong" and "right" may change if SelfLoader is changed.
84 my %wrong = ( Parent => 'Parent', Child => 'Parent' );
85 my %right = ( Parent => 'Parent', Child => 'Child' );
86 my @module = qw(Parent Child)
87 ;
88 sub fail {
89   my ($left, $right) = @_;
90   while (my ($key, $val) = each %$left) {
91     # warn "$key $val $$right{$key}";
92     return 1
93       unless $val eq $$right{$key};
94   }
95   return;
96 }
97
98 sub faildump {
99   my ($expect, $got) = @_;
100   foreach (sort keys %$expect) {
101     print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n";
102   }
103 }
104
105 # Now test that the module tree behaves "wrongly" as expected
106
107 foreach my $module (@module) {
108   my $file = "$module--$$";
109   push @cleanup, $file;
110   open FH, ">$file" or die $!;
111   print FH "use $module;
112 print ${module}->foo;
113 ";
114   close FH or die $!;
115 }
116
117 {
118   my %output;
119   foreach my $module (@module) {
120     ($output{$module} = `$runperl -I $inlib $module--$$`)
121       =~ s/\'s foo//;
122   }
123
124   if (&fail (\%wrong, \%output)) {
125     print "not ok 5\n", &faildump (\%wrong, \%output);
126   } else {
127     print "ok 5\n";
128   }
129 }
130
131 my $lib="SSO-$$";
132 mkdir $lib, 0777 or die $!;
133 push @cleanup, $lib;
134 $Devel::SelfStubber::JUST_STUBS=0;
135
136 undef $/;
137 foreach my $module (@module) {
138   my $file = "$lib/$module.pm";
139   open FH, "$inlib/$module.pm" or die $!;
140   my $contents = <FH>;
141   close FH or die $!;
142   push @cleanup, $file;
143   open FH, ">$file" or die $!;
144   select FH;
145   if ($contents =~ /__DATA__/) {
146     # This will die for any module with no  __DATA__
147     Devel::SelfStubber->stub($module, $inlib);
148   } else {
149     print $contents;
150   }
151   select STDOUT;
152   close FH or die $!;
153 }
154 print "ok 6\n";
155
156 {
157   my %output;
158   foreach my $module (@module) {
159     ($output{$module} = `$runperl -I $lib $module--$$`)
160       =~ s/\'s foo//;
161   }
162
163   if (&fail (\%right, \%output)) {
164     print "not ok 7\n", &faildump (\%right, \%output);
165   } else {
166     print "ok 7\n";
167   }
168 }
169
170 __DATA__
171 ################ Parent.pm
172 package Parent;
173
174 sub foo {
175   return __PACKAGE__;
176 }
177 1;
178 __END__
179 ################ Child.pm
180 package Child;
181 require Parent;
182 @ISA = 'Parent';
183 use SelfLoader;
184
185 1;
186 __DATA__
187 sub foo {
188   return __PACKAGE__;
189 }
190 __END__
191 ################ Proto.pm
192 package Proto;
193 use SelfLoader;
194
195 1;
196 __DATA__
197 sub bar ($$) {
198 }