Commit | Line | Data |
---|---|---|
6aaee015 RGS |
1 | ### make sure we can find our conf.pl file |
2 | BEGIN { | |
3 | use FindBin; | |
4 | require "$FindBin::Bin/inc/conf.pl"; | |
5 | } | |
6 | ||
7 | use strict; | |
8 | use Test::More 'no_plan'; | |
9 | use File::Basename 'dirname'; | |
10 | ||
11 | use Data::Dumper; | |
12 | use CPANPLUS::Error; | |
13 | use CPANPLUS::Internals::Constants; | |
14 | ||
15 | my $conf = gimme_conf(); | |
16 | ||
6aaee015 RGS |
17 | my $Class = 'CPANPLUS::Backend'; |
18 | ### D::C has troubles with the 'use_ok' -- it finds the wrong paths. | |
19 | ### for now, do a 'use' instead | |
20 | #use_ok( $Class ) or diag "$Class not found"; | |
21 | use CPANPLUS::Backend; | |
22 | ||
23 | my $cb = $Class->new( $conf ); | |
24 | isa_ok( $cb, $Class ); | |
25 | ||
26 | my $mt = $cb->module_tree; | |
27 | my $at = $cb->author_tree; | |
28 | ok( scalar keys %$mt, "Module tree has entries" ); | |
29 | ok( scalar keys %$at, "Author tree has entries" ); | |
30 | ||
31 | ### module_tree tests ### | |
32 | my $Name = TEST_CONF_MODULE; | |
33 | my $mod = $cb->module_tree($Name); | |
34 | ||
35 | ### XXX SOURCEFILES FIX | |
36 | { my @mods = $cb->module_tree($Name,$Name); | |
37 | my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE ); | |
38 | ||
39 | ok( IS_MODOBJ->(mod => $mod), "Module object found" ); | |
40 | is( scalar(@mods), 2, " Module list found" ); | |
41 | ok( IS_MODOBJ->(mod => $mods[0]), " ISA module object" ); | |
42 | ok( !IS_MODOBJ->(mod => $none), " Bogus module detected"); | |
43 | } | |
44 | ||
45 | ### author_tree tests ### | |
46 | { my @auths = $cb->author_tree( $mod->author->cpanid, | |
47 | $mod->author->cpanid ); | |
48 | my $none = $cb->author_tree( 'fnurk' ); | |
49 | ||
50 | ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" ); | |
51 | is( scalar(@auths), 2, " Author list found" ); | |
52 | ok( IS_AUTHOBJ->( author => $auths[0] )," ISA author object" ); | |
53 | is( $mod->author, $auths[0], " Objects are identical" ); | |
54 | ok( !IS_AUTHOBJ->( author => $none ), " Bogus author detected" ); | |
55 | } | |
56 | ||
57 | my $conf_obj = $cb->configure_object; | |
58 | ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); | |
59 | ||
60 | ||
61 | ### parse_module tests ### | |
4443dd53 JB |
62 | { my @map = ( |
63 | $Name => [ | |
64 | $mod->author->cpanid, # author | |
65 | $mod->package_name, # package name | |
66 | $mod->version, # version | |
67 | ], | |
68 | $mod => [ | |
69 | $mod->author->cpanid, | |
70 | $mod->package_name, | |
71 | $mod->version, | |
72 | ], | |
73 | 'Foo-Bar-EU-NOXS' => [ | |
74 | $mod->author->cpanid, | |
75 | $mod->package_name, | |
76 | $mod->version, | |
77 | ], | |
78 | 'Foo-Bar-EU-NOXS-0.01' => [ | |
79 | $mod->author->cpanid, | |
80 | $mod->package_name, | |
81 | '0.01', | |
82 | ], | |
83 | 'EUNOXS/Foo-Bar-EU-NOXS' => [ | |
84 | 'EUNOXS', | |
85 | $mod->package_name, | |
86 | $mod->version, | |
87 | ], | |
88 | 'EUNOXS/Foo-Bar-EU-NOXS-0.01' => [ | |
89 | 'EUNOXS', | |
90 | $mod->package_name, | |
91 | '0.01', | |
92 | ], | |
93 | ### existing module, no extension given | |
94 | ### this used to create a modobj with no package extension | |
95 | 'EUNOXS/Foo-Bar-0.02' => [ | |
96 | 'EUNOXS', | |
97 | 'Foo-Bar', | |
98 | '0.02', | |
99 | ], | |
100 | 'Foo-Bar-EU-NOXS-0.09' => [ | |
101 | $mod->author->cpanid, | |
102 | $mod->package_name, | |
103 | '0.09', | |
104 | ], | |
105 | 'MBXS/Foo-Bar-EU-NOXS-0.01' => [ | |
106 | 'MBXS', | |
107 | $mod->package_name, | |
108 | '0.01', | |
109 | ], | |
110 | 'EUNOXS/Foo-Bar-EU-NOXS-0.09' => [ | |
111 | 'EUNOXS', | |
112 | $mod->package_name, | |
113 | '0.09', | |
114 | ], | |
115 | 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' => [ | |
116 | 'EUNOXS', | |
117 | $mod->package_name, | |
118 | '0.09', | |
119 | ], | |
120 | 'FROO/Flub-Flob-1.1.zip' => [ | |
121 | 'FROO', | |
122 | 'Flub-Flob', | |
123 | '1.1', | |
124 | ], | |
125 | 'G/GO/GOYALI/SMS_API_3_01.tar.gz' => [ | |
126 | 'GOYALI', | |
127 | 'SMS_API', | |
128 | '3_01', | |
129 | ], | |
130 | 'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ | |
131 | 'EYCK', | |
132 | 'Net-Lite-FTP', | |
133 | '0.091', | |
134 | ], | |
135 | 'EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ | |
136 | 'EYCK', | |
137 | 'Net-Lite-FTP', | |
138 | '0.091', | |
139 | ], | |
140 | 'M/MA/MAXDB/DBD-MaxDB-7.5.0.24a' => [ | |
141 | 'MAXDB', | |
142 | 'DBD-MaxDB', | |
143 | '7.5.0.24a', | |
144 | ], | |
145 | 'EUNOXS/perl5.005_03.tar.gz' => [ | |
146 | 'EUNOXS', | |
147 | 'perl', | |
148 | '5.005_03', | |
149 | ], | |
150 | 'FROO/Flub-Flub-v1.1.0.tbz' => [ | |
151 | 'FROO', | |
152 | 'Flub-Flub', | |
153 | 'v1.1.0', | |
154 | ], | |
155 | 'FROO/Flub-Flub-1.1_2.tbz' => [ | |
156 | 'FROO', | |
157 | 'Flub-Flub', | |
158 | '1.1_2', | |
159 | ], | |
160 | 'LDS/CGI.pm-3.27.tar.gz' => [ | |
161 | 'LDS', | |
162 | 'CGI', | |
163 | '3.27', | |
164 | ], | |
165 | 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' => [ | |
166 | 'FROO', | |
167 | 'Text-Tabs+Wrap', | |
168 | '2006.1117', | |
169 | ], | |
170 | 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9' => [ | |
171 | 'JETTERO', | |
172 | 'Crypt-PBC', | |
173 | '0.7.20.0-0.4.9' , | |
174 | ], | |
175 | 'GRICHTER/HTML-Embperl-1.2.1.tar.gz' => [ | |
176 | 'GRICHTER', | |
177 | 'HTML-Embperl', | |
178 | '1.2.1', | |
179 | ], | |
180 | 'KANE/File-Fetch-0.15_03' => [ | |
181 | 'KANE', | |
182 | 'File-Fetch', | |
183 | '0.15_03', | |
184 | ], | |
185 | 'AUSCHUTZ/IO-Stty-.02.tar.gz' => [ | |
186 | 'AUSCHUTZ', | |
187 | 'IO-Stty', | |
188 | '.02', | |
189 | ], | |
a0995fd4 JB |
190 | '.' => [ |
191 | 'CPANPLUS', | |
192 | 't', | |
193 | '', | |
194 | ], | |
6aaee015 RGS |
195 | ); |
196 | ||
197 | while ( my($guess, $attr) = splice @map, 0, 2 ) { | |
4443dd53 | 198 | my( $author, $pkg_name, $version ) = @$attr; |
6aaee015 RGS |
199 | |
200 | ok( $guess, "Attempting to parse $guess" ); | |
201 | ||
202 | my $obj = $cb->parse_module( module => $guess ); | |
203 | ||
204 | ok( $obj, " Result returned" ); | |
205 | ok( IS_MODOBJ->( mod => $obj ), | |
206 | " parse_module success by '$guess'" ); | |
207 | ||
208 | is( $obj->version, $version, | |
209 | " Proper version found: $version" ); | |
210 | is( $obj->package_version, $version, | |
211 | " Found in package_version as well" ); | |
a3de5d0b JB |
212 | |
213 | ### VMS doesn't preserve case, so match them after normalizing case | |
214 | is( uc($obj->package_name), uc($pkg_name), | |
4443dd53 | 215 | " Proper package_name found: $pkg_name" ); |
6aaee015 RGS |
216 | unlike( $obj->package_name, qr/\d/, |
217 | " No digits in package name" ); | |
4443dd53 JB |
218 | { my $ext = $obj->package_extension; |
219 | ok( $ext, " Has extension as well: $ext" ); | |
220 | } | |
221 | ||
6aaee015 RGS |
222 | like( $obj->author->cpanid, "/$author/i", |
223 | " Proper author found: $author"); | |
224 | like( $obj->path, "/$author/i", | |
225 | " Proper path found: " . $obj->path ); | |
226 | } | |
227 | ||
228 | ||
229 | ### test for things that look like real modules, but aren't ### | |
983ffab6 | 230 | { my @map = ( |
6aaee015 RGS |
231 | [ $Name . $$ => [ |
232 | [qr/does not contain an author/,"Missing author part detected"], | |
233 | [qr/Cannot find .+? in the module tree/,"Unable to find module"] | |
234 | ] ], | |
235 | [ {}, => [ | |
236 | [ qr/module string from reference/,"Unable to parse ref"] | |
237 | ] ], | |
238 | ); | |
239 | ||
240 | for my $entry ( @map ) { | |
241 | my($mod,$aref) = @$entry; | |
242 | ||
243 | my $none = $cb->parse_module( module => $mod ); | |
244 | ok( !IS_MODOBJ->(mod => $none), | |
245 | "Non-existant module detected" ); | |
246 | ok( !IS_FAKE_MODOBJ->(mod => $none), | |
247 | "Non-existant fake module detected" ); | |
248 | ||
249 | my $str = CPANPLUS::Error->stack_as_string; | |
250 | for my $pair (@$aref) { | |
251 | my($re,$diag) = @$pair; | |
252 | like( $str, $re," $diag" ); | |
253 | } | |
254 | } | |
255 | } | |
256 | ||
257 | ### test parsing of arbitrary URI | |
258 | for my $guess ( qw[ http://foo/bar.gz | |
259 | http://a/b/c/d/e/f/g/h/i/j | |
260 | flub://floo ] | |
261 | ) { | |
262 | my $obj = $cb->parse_module( module => $guess ); | |
5bc5f6dc RGS |
263 | ok( IS_FAKE_MODOBJ->(mod => $obj), |
264 | "parse_module success by '$guess'" ); | |
6aaee015 | 265 | is( $obj->status->_fetch_from, $guess, |
5bc5f6dc | 266 | " Fetch from set ok" ); |
6aaee015 RGS |
267 | } |
268 | } | |
269 | ||
270 | ### RV tests ### | |
271 | { my $method = 'readme'; | |
272 | my %args = ( modules => [$Name] ); | |
273 | ||
274 | my $rv = $cb->$method( %args ); | |
275 | ok( IS_RVOBJ->( $rv ), "Got an RV object" ); | |
276 | ok( $rv->ok, " Overall OK" ); | |
277 | cmp_ok( $rv, '==', 1, " Overload OK" ); | |
278 | is( $rv->function, $method, " Function stored OK" ); | |
279 | is_deeply( $rv->args, \%args, " Arguments stored OK" ); | |
280 | is( $rv->rv->{$Name}, $mod->readme, " RV as expected" ); | |
281 | } | |
282 | ||
283 | ### reload_indices tests ### | |
284 | { | |
285 | my $file = File::Spec->catfile( $conf->get_conf('base'), | |
286 | $conf->_get_source('mod'), | |
287 | ); | |
288 | ||
289 | ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); | |
290 | my $age = -M $file; | |
291 | ||
292 | ### make sure we are 'newer' on faster machines with a sleep.. | |
293 | ### apparently Win32's FAT isn't granual enough on intervals | |
294 | ### < 2 seconds, so it may give the same answer before and after | |
295 | ### the sleep, causing the test to fail. so sleep atleast 2 seconds. | |
296 | sleep 2; | |
297 | ok( $cb->reload_indices( update_source => 1 ), | |
298 | "Rebuilding and refetching trees" ); | |
299 | cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); | |
300 | } | |
301 | ||
302 | ### flush tests ### | |
303 | { | |
304 | for my $cache( qw[methods hosts modules lib all] ) { | |
305 | ok( $cb->flush($cache), "Cache $cache flushed ok" ); | |
306 | } | |
307 | } | |
308 | ||
309 | ### installed tests ### | |
5bc5f6dc | 310 | { ok( scalar($cb->installed), "Found list of installed modules" ); |
6aaee015 RGS |
311 | } |
312 | ||
313 | ### autobudle tests ### | |
314 | { | |
315 | my $where = $cb->autobundle; | |
316 | ok( $where, "Autobundle written" ); | |
317 | ok( -s $where, " File has size" ); | |
318 | } | |
319 | ||
320 | ### local_mirror tests ### | |
321 | { ### turn off md5 checks for the 'fake' packages we have | |
322 | my $old_md5 = $conf->get_conf('md5'); | |
323 | $conf->set_conf( md5 => 0 ); | |
324 | ||
325 | ### otherwise 'status->fetch' might be undef! ### | |
326 | my $rv = $cb->local_mirror( path => 'dummy-localmirror' ); | |
327 | ok( $rv, "Local mirror created" ); | |
328 | ||
329 | for my $mod ( values %{ $cb->module_tree } ) { | |
330 | my $name = $mod->module; | |
331 | ||
332 | my $cksum = File::Spec->catfile( | |
333 | dirname($mod->status->fetch), | |
334 | CHECKSUMS ); | |
335 | ok( -e $mod->status->fetch, " Module '$name' fetched" ); | |
336 | ok( -s _, " Module '$name' has size" ); | |
337 | ok( -e $cksum, " Checksum fetched for '$name'" ); | |
338 | ok( -s _, " Checksum for '$name' has size" ); | |
339 | } | |
340 | ||
341 | $conf->set_conf( md5 => $old_md5 ); | |
342 | } | |
343 | ||
344 | ### check ENV variable | |
345 | { ### process id | |
346 | { my $name = 'PERL5_CPANPLUS_IS_RUNNING'; | |
347 | ok( $ENV{$name}, "Env var '$name' set" ); | |
348 | is( $ENV{$name}, $$, " Set to current process id" ); | |
349 | } | |
350 | ||
351 | ### Version | |
352 | { my $name = 'PERL5_CPANPLUS_IS_VERSION'; | |
353 | ok( $ENV{$name}, "Env var '$name' set" ); | |
354 | ||
355 | ### version.pm formats ->VERSION output... *sigh* | |
356 | is( $ENV{$name}, $Class->VERSION, | |
357 | " Set to current process version" ); | |
358 | } | |
359 | ||
360 | } | |
361 | ||
362 | __END__ | |
363 | ||
364 | # Local variables: | |
365 | # c-indentation-style: bsd | |
366 | # c-basic-offset: 4 | |
367 | # indent-tabs-mode: nil | |
368 | # End: | |
369 | # vim: expandtab shiftwidth=4: | |
370 |