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 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 ### 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 ], 190 'MARKOV/POSIX-1003-0.99_05' => [ 191 'MARKOV', 192 'POSIX-1003', 193 '0.99_05', 194 ], 195 'BBENNETT/Unicode-Collate-Standard-V3_1_1-0.1' => [ 196 'BBENNETT', 197 'Unicode-Collate-Standard-V3_1_1', 198 '0.1', 199 ], 200 'RURBAN/B-Utils1-1.02.tar.gz' => [ 201 'RURBAN', 202 'B-Utils1', 203 '1.02', 204 ], 205 '.' => [ 206 'CPANPLUS', 207 't', 208 '', 209 ], 210 'Foo/Bar.pm' => [ 211 $mod->author->cpanid, # author 212 $mod->package_name, # package name 213 $mod->version, # version 214 ], 215 'Digest-SHA1' => [ 216 'EUNOXS', 217 'Digest-SHA1', 218 '2.13', 219 ], 220 ); 221 222 while ( my($guess, $attr) = splice @map, 0, 2 ) { 223 my( $author, $pkg_name, $version ) = @$attr; 224 225 ok( $guess, "Attempting to parse $guess" ); 226 227 my $obj = $cb->parse_module( module => $guess ); 228 229 ok( $obj, " Result returned" ); 230 ok( IS_MODOBJ->( mod => $obj ), 231 " parse_module success by '$guess'" ); 232 233 is( $obj->version, $version, 234 " Proper version found: $version" ); 235 is( $obj->package_version, $version, 236 " Found in package_version as well" ); 237 238 ### VMS doesn't preserve case, so match them after normalizing case 239 is( uc($obj->package_name), uc($pkg_name), 240 " Proper package_name found: $pkg_name" ); 241 if ( $pkg_name =~ m!\d! ) { 242 like( $obj->package_name, qr/\d/, 243 " Digits in package name" ); 244 } 245 else { 246 unlike( $obj->package_name, qr/\d/, 247 " No digits in package name" ); 248 } 249 { my $ext = $obj->package_extension; 250 ok( $ext, " Has extension as well: $ext" ); 251 } 252 253 like( $obj->author->cpanid, "/$author/i", 254 " Proper author found: $author"); 255 like( $obj->path, "/$author/i", 256 " Proper path found: " . $obj->path ); 257 } 258 259 260 ### test for things that look like real modules, but aren't ### 261 { my @map = ( 262 [ $Name . $$ => [ 263 [qr/does not contain an author/,"Missing author part detected"], 264 [qr/Cannot find .+? in the module tree/,"Unable to find module"] 265 ] ], 266 [ {}, => [ 267 [ qr/module string from reference/,"Unable to parse ref"] 268 ] ], 269 ); 270 271 for my $entry ( @map ) { 272 my($mod,$aref) = @$entry; 273 274 my $none = $cb->parse_module( module => $mod ); 275 ok( !IS_MODOBJ->(mod => $none), 276 "Non-existent module detected" ); 277 ok( !IS_FAKE_MODOBJ->(mod => $none), 278 "Non-existent fake module detected" ); 279 280 my $str = CPANPLUS::Error->stack_as_string; 281 for my $pair (@$aref) { 282 my($re,$diag) = @$pair; 283 like( $str, $re," $diag" ); 284 } 285 } 286 } 287 288 ### test parsing of arbitrary URI 289 for my $guess ( qw[ http://foo/bar.gz 290 http://a/b/c/d/e/f/g/h/i/j 291 flub://floo ] 292 ) { 293 my $obj = $cb->parse_module( module => $guess ); 294 ok( IS_FAKE_MODOBJ->(mod => $obj), 295 "parse_module success by '$guess'" ); 296 is( $obj->status->_fetch_from, $guess, 297 " Fetch from set ok" ); 298 } 299} 300 301### RV tests ### 302{ my $method = 'readme'; 303 my %args = ( modules => [$Name] ); 304 305 my $rv = $cb->$method( %args ); 306 ok( IS_RVOBJ->( $rv ), "Got an RV object" ); 307 ok( $rv->ok, " Overall OK" ); 308 cmp_ok( $rv, '==', 1, " Overload OK" ); 309 is( $rv->function, $method, " Function stored OK" ); 310 is_deeply( $rv->args, \%args, " Arguments stored OK" ); 311 is( $rv->rv->{$Name}, $mod->readme, " RV as expected" ); 312} 313 314### reload_indices tests ### 315{ 316 my $file = File::Spec->catfile( $conf->get_conf('base'), 317 $conf->_get_source('mod'), 318 ); 319 320 ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); 321 my $age = -M $file; 322 323 ### make sure we are 'newer' on faster machines with a sleep.. 324 ### apparently Win32's FAT isn't granual enough on intervals 325 ### < 2 seconds, so it may give the same answer before and after 326 ### the sleep, causing the test to fail. so sleep atleast 2 seconds. 327 sleep 2; 328 ok( $cb->reload_indices( update_source => 1 ), 329 "Rebuilding and refetching trees" ); 330 cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); 331} 332 333### flush tests ### 334{ 335 for my $cache( qw[methods hosts modules lib all] ) { 336 ok( $cb->flush($cache), "Cache $cache flushed ok" ); 337 } 338} 339 340### installed tests ### 341{ ok( scalar($cb->installed), "Found list of installed modules" ); 342} 343 344### autobudle tests ### 345{ 346 my $where = $cb->autobundle; 347 ok( $where, "Autobundle written" ); 348 ok( -s $where, " File has size" ); 349} 350 351### local_mirror tests ### 352{ ### turn off md5 checks for the 'fake' packages we have 353 my $old_md5 = $conf->get_conf('md5'); 354 $conf->set_conf( md5 => 0 ); 355 356 ### otherwise 'status->fetch' might be undef! ### 357 my $rv = $cb->local_mirror( path => 'dummy-localmirror' ); 358 ok( $rv, "Local mirror created" ); 359 360 for my $mod ( values %{ $cb->module_tree } ) { 361 my $name = $mod->module; 362 363 my $cksum = File::Spec->catfile( 364 dirname($mod->status->fetch), 365 CHECKSUMS ); 366 ok( -e $mod->status->fetch, " Module '$name' fetched" ); 367 ok( -s _, " Module '$name' has size" ); 368 ok( -e $cksum, " Checksum fetched for '$name'" ); 369 ok( -s _, " Checksum for '$name' has size" ); 370 } 371 372 $conf->set_conf( md5 => $old_md5 ); 373} 374 375### check ENV variable 376{ ### process id 377 { my $name = 'PERL5_CPANPLUS_IS_RUNNING'; 378 ok( $ENV{$name}, "Env var '$name' set" ); 379 is( $ENV{$name}, $$, " Set to current process id" ); 380 } 381 382 ### Version 383 { my $name = 'PERL5_CPANPLUS_IS_VERSION'; 384 ok( $ENV{$name}, "Env var '$name' set" ); 385 386 ### version.pm formats ->VERSION output... *sigh* 387 is( $ENV{$name}, $Class->VERSION, 388 " Set to current process version" ); 389 } 390 391} 392 393__END__ 394 395# Local variables: 396# c-indentation-style: bsd 397# c-basic-offset: 4 398# indent-tabs-mode: nil 399# End: 400# vim: expandtab shiftwidth=4: 401 402