1 | #!./perl
|
---|
2 |
|
---|
3 | BEGIN {
|
---|
4 | chdir 't' if -d 't';
|
---|
5 | $dir = "self-$$";
|
---|
6 | $sep = "/";
|
---|
7 |
|
---|
8 | if ($^O eq 'MacOS') {
|
---|
9 | $dir = ":" . $dir;
|
---|
10 | $sep = ":";
|
---|
11 | }
|
---|
12 |
|
---|
13 | @INC = $dir;
|
---|
14 | push @INC, '../lib';
|
---|
15 |
|
---|
16 | print "1..19\n";
|
---|
17 |
|
---|
18 | # First we must set up some selfloader files
|
---|
19 | mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
|
---|
20 |
|
---|
21 | open(FOO, ">$dir${sep}Foo.pm") or die;
|
---|
22 | print FOO <<'EOT';
|
---|
23 | package Foo;
|
---|
24 | use SelfLoader;
|
---|
25 |
|
---|
26 | sub new { bless {}, shift }
|
---|
27 | sub foo;
|
---|
28 | sub bar;
|
---|
29 | sub bazmarkhianish;
|
---|
30 | sub a;
|
---|
31 | sub never; # declared but definition should never be read
|
---|
32 | 1;
|
---|
33 | __DATA__
|
---|
34 |
|
---|
35 | sub foo { shift; shift || "foo" };
|
---|
36 |
|
---|
37 | sub bar { shift; shift || "bar" }
|
---|
38 |
|
---|
39 | sub bazmarkhianish { shift; shift || "baz" }
|
---|
40 |
|
---|
41 | package sheep;
|
---|
42 | sub bleat { shift; shift || "baa" }
|
---|
43 |
|
---|
44 | __END__
|
---|
45 | sub never { die "D'oh" }
|
---|
46 | EOT
|
---|
47 |
|
---|
48 | close(FOO);
|
---|
49 |
|
---|
50 | open(BAR, ">$dir${sep}Bar.pm") or die;
|
---|
51 | print BAR <<'EOT';
|
---|
52 | package Bar;
|
---|
53 | use SelfLoader;
|
---|
54 |
|
---|
55 | @ISA = 'Baz';
|
---|
56 |
|
---|
57 | sub new { bless {}, shift }
|
---|
58 | sub a;
|
---|
59 |
|
---|
60 | 1;
|
---|
61 | __DATA__
|
---|
62 |
|
---|
63 | sub a { 'a Bar'; }
|
---|
64 | sub b { 'b Bar' }
|
---|
65 |
|
---|
66 | __END__ DATA
|
---|
67 | sub never { die "D'oh" }
|
---|
68 | EOT
|
---|
69 |
|
---|
70 | close(BAR);
|
---|
71 | };
|
---|
72 |
|
---|
73 |
|
---|
74 | package Baz;
|
---|
75 |
|
---|
76 | sub a { 'a Baz' }
|
---|
77 | sub b { 'b Baz' }
|
---|
78 | sub c { 'c Baz' }
|
---|
79 |
|
---|
80 |
|
---|
81 | package main;
|
---|
82 | use Foo;
|
---|
83 | use Bar;
|
---|
84 |
|
---|
85 | $foo = new Foo;
|
---|
86 |
|
---|
87 | print "not " unless $foo->foo eq 'foo'; # selfloaded first time
|
---|
88 | print "ok 1\n";
|
---|
89 |
|
---|
90 | print "not " unless $foo->foo eq 'foo'; # regular call
|
---|
91 | print "ok 2\n";
|
---|
92 |
|
---|
93 | # Try an undefined method
|
---|
94 | eval {
|
---|
95 | $foo->will_fail;
|
---|
96 | };
|
---|
97 | if ($@ =~ /^Undefined subroutine/) {
|
---|
98 | print "ok 3\n";
|
---|
99 | } else {
|
---|
100 | print "not ok 3 $@\n";
|
---|
101 | }
|
---|
102 |
|
---|
103 | # Used to be trouble with this
|
---|
104 | eval {
|
---|
105 | my $foo = new Foo;
|
---|
106 | die "oops";
|
---|
107 | };
|
---|
108 | if ($@ =~ /oops/) {
|
---|
109 | print "ok 4\n";
|
---|
110 | } else {
|
---|
111 | print "not ok 4 $@\n";
|
---|
112 | }
|
---|
113 |
|
---|
114 | # Pass regular expression variable to autoloaded function. This used
|
---|
115 | # to go wrong in AutoLoader because it used regular expressions to generate
|
---|
116 | # autoloaded filename.
|
---|
117 | "foo" =~ /(\w+)/;
|
---|
118 | print "not " unless $1 eq 'foo';
|
---|
119 | print "ok 5\n";
|
---|
120 |
|
---|
121 | print "not " unless $foo->bar($1) eq 'foo';
|
---|
122 | print "ok 6\n";
|
---|
123 |
|
---|
124 | print "not " unless $foo->bar($1) eq 'foo';
|
---|
125 | print "ok 7\n";
|
---|
126 |
|
---|
127 | print "not " unless $foo->bazmarkhianish($1) eq 'foo';
|
---|
128 | print "ok 8\n";
|
---|
129 |
|
---|
130 | print "not " unless $foo->bazmarkhianish($1) eq 'foo';
|
---|
131 | print "ok 9\n";
|
---|
132 |
|
---|
133 | # Check nested packages inside __DATA__
|
---|
134 | print "not " unless sheep::bleat() eq 'baa';
|
---|
135 | print "ok 10\n";
|
---|
136 |
|
---|
137 | # Now check inheritance:
|
---|
138 |
|
---|
139 | $bar = new Bar;
|
---|
140 |
|
---|
141 | # Before anything is SelfLoaded there is no declaration of Foo::b so we should
|
---|
142 | # get Baz::b
|
---|
143 | print "not " unless $bar->b() eq 'b Baz';
|
---|
144 | print "ok 11\n";
|
---|
145 |
|
---|
146 | # There is no Bar::c so we should get Baz::c
|
---|
147 | print "not " unless $bar->c() eq 'c Baz';
|
---|
148 | print "ok 12\n";
|
---|
149 |
|
---|
150 | # This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side
|
---|
151 | # effect
|
---|
152 | print "not " unless $bar->a() eq 'a Bar';
|
---|
153 | print "ok 13\n";
|
---|
154 |
|
---|
155 | print "not " unless $bar->b() eq 'b Bar';
|
---|
156 | print "ok 14\n";
|
---|
157 |
|
---|
158 | print "not " unless $bar->c() eq 'c Baz';
|
---|
159 | print "ok 15\n";
|
---|
160 |
|
---|
161 |
|
---|
162 |
|
---|
163 | # Check that __END__ is honoured
|
---|
164 | # Try an subroutine that should never be noticed by selfloader
|
---|
165 | eval {
|
---|
166 | $foo->never;
|
---|
167 | };
|
---|
168 | if ($@ =~ /^Undefined subroutine/) {
|
---|
169 | print "ok 16\n";
|
---|
170 | } else {
|
---|
171 | print "not ok 16 $@\n";
|
---|
172 | }
|
---|
173 |
|
---|
174 | # Try to read from the data file handle
|
---|
175 | my $foodata = <Foo::DATA>;
|
---|
176 | close Foo::DATA;
|
---|
177 | if (defined $foodata) {
|
---|
178 | print "not ok 17 # $foodata\n";
|
---|
179 | } else {
|
---|
180 | print "ok 17\n";
|
---|
181 | }
|
---|
182 |
|
---|
183 | # Check that __END__ DATA is honoured
|
---|
184 | # Try an subroutine that should never be noticed by selfloader
|
---|
185 | eval {
|
---|
186 | $bar->never;
|
---|
187 | };
|
---|
188 | if ($@ =~ /^Undefined subroutine/) {
|
---|
189 | print "ok 18\n";
|
---|
190 | } else {
|
---|
191 | print "not ok 18 $@\n";
|
---|
192 | }
|
---|
193 |
|
---|
194 | # Try to read from the data file handle
|
---|
195 | my $bardata = <Bar::DATA>;
|
---|
196 | close Bar::DATA;
|
---|
197 | if ($bardata ne "sub never { die \"D'oh\" }\n") {
|
---|
198 | print "not ok 19 # $bardata\n";
|
---|
199 | } else {
|
---|
200 | print "ok 19\n";
|
---|
201 | }
|
---|
202 |
|
---|
203 | # cleanup
|
---|
204 | END {
|
---|
205 | return unless $dir && -d $dir;
|
---|
206 | unlink "$dir${sep}Foo.pm", "$dir${sep}Bar.pm";
|
---|
207 | rmdir "$dir";
|
---|
208 | }
|
---|