This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Changes to CPANPLUS and CPANPLUS::Dist::Build tests
[perl5.git] / cpan / CPANPLUS / t / 08_CPANPLUS-Backend.t
CommitLineData
6aaee015
RGS
1### make sure we can find our conf.pl file
2BEGIN {
3 use FindBin;
4 require "$FindBin::Bin/inc/conf.pl";
5}
6
7use strict;
8use Test::More 'no_plan';
9use File::Basename 'dirname';
10
11use Data::Dumper;
12use CPANPLUS::Error;
13use CPANPLUS::Internals::Constants;
14
15my $conf = gimme_conf();
16
6aaee015
RGS
17my $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";
21use CPANPLUS::Backend;
22
23my $cb = $Class->new( $conf );
24isa_ok( $cb, $Class );
25
26my $mt = $cb->module_tree;
27my $at = $cb->author_tree;
28ok( scalar keys %$mt, "Module tree has entries" );
29ok( scalar keys %$at, "Author tree has entries" );
30
31### module_tree tests ###
32my $Name = TEST_CONF_MODULE;
33my $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
57my $conf_obj = $cb->configure_object;
58ok( 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