ext/CPANPLUS/t/08_CPANPLUS-Backend.t

   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
  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 ###
  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         '.' => [
 191             'CPANPLUS',
 192             't',
 193             '',
 194         ],
 195     );
 196
 197     while ( my($guess, $attr) = splice @map, 0, 2 ) {
 198         my( $author, $pkg_name, $version ) = @$attr;
 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" );
 212
 213         ### VMS doesn't preserve case, so match them after normalizing case
 214         is( uc($obj->package_name), uc($pkg_name),
 215                                 "   Proper package_name found: $pkg_name" );
 216         unlike( $obj->package_name, qr/\d/,
 217                                 "       No digits in package name" );
 218         {   my $ext = $obj->package_extension;
 219             ok( $ext,           "       Has extension as well: $ext" );
 220         }
 221
 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 ###
 230     {   my @map = (
 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 );
 263         ok( IS_FAKE_MODOBJ->(mod => $obj),
 264                                 "parse_module success by '$guess'" );
 265         is( $obj->status->_fetch_from, $guess,
 266                                 "   Fetch from set ok" );
 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 ###
 310 {   ok( scalar($cb->installed), "Found list of installed modules" );
 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