lib/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 ### purposely avert messages and errors to a file? ###
  18 my $Trap_Output = @ARGV ? 0 : 1;
  19
  20 my $Class = 'CPANPLUS::Backend';
  21 ### D::C has troubles with the 'use_ok' -- it finds the wrong paths.
  22 ### for now, do a 'use' instead
  23 #use_ok( $Class ) or diag "$Class not found";
  24 use CPANPLUS::Backend;
  25
  26 my $cb = $Class->new( $conf );
  27 isa_ok( $cb, $Class );
  28
  29 my $mt = $cb->module_tree;
  30 my $at = $cb->author_tree;
  31 ok( scalar keys %$mt,       "Module tree has entries" );
  32 ok( scalar keys %$at,       "Author tree has entries" );
  33
  34 ### module_tree tests ###
  35 my $Name = TEST_CONF_MODULE;
  36 my $mod  = $cb->module_tree($Name);
  37
  38 ### XXX SOURCEFILES FIX
  39 {   my @mods = $cb->module_tree($Name,$Name);
  40     my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE );
  41
  42     ok( IS_MODOBJ->(mod => $mod),           "Module object found" );
  43     is( scalar(@mods), 2,                   "   Module list found" );
  44     ok( IS_MODOBJ->(mod => $mods[0]),       "   ISA module object" );
  45     ok( !IS_MODOBJ->(mod => $none),         "   Bogus module detected");
  46 }
  47
  48 ### author_tree tests ###
  49 {   my @auths = $cb->author_tree( $mod->author->cpanid,
  50                                   $mod->author->cpanid );
  51     my $none  = $cb->author_tree( 'fnurk' );
  52
  53     ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" );
  54     is( scalar(@auths), 2,                  "   Author list found" );
  55     ok( IS_AUTHOBJ->( author => $auths[0] ),"   ISA author object" );
  56     is( $mod->author, $auths[0],            "   Objects are identical" );
  57     ok( !IS_AUTHOBJ->( author => $none ),   "   Bogus author detected" );
  58 }
  59
  60 my $conf_obj = $cb->configure_object;
  61 ok( IS_CONFOBJ->(conf => $conf_obj),    "Configure object found" );
  62
  63
  64 ### parse_module tests ###
  65 {   my @map = (     # author                package             version
  66         $Name   => [ $mod->author->cpanid,  $mod->package_name, $mod->version ],
  67         $mod    => [ $mod->author->cpanid,  $mod->package_name, $mod->version ],
  68         'Foo-Bar-EU-NOXS'
  69                 => [ $mod->author->cpanid,  $mod->package_name, $mod->version ],
  70         'Foo-Bar-EU-NOXS-0.01'
  71                 => [ $mod->author->cpanid,  $mod->package_name, '0.01' ],
  72         'EUNOXS/Foo-Bar-EU-NOXS'
  73                 => [ 'EUNOXS',              $mod->package_name, $mod->version ],
  74         'EUNOXS/Foo-Bar-EU-NOXS-0.01'
  75                 => [ 'EUNOXS',              $mod->package_name, '0.01' ],
  76         'Foo-Bar-EU-NOXS-0.09'
  77                 => [ $mod->author->cpanid,  $mod->package_name, '0.09' ],
  78         'MBXS/Foo-Bar-EU-NOXS-0.01'
  79                 => [ 'MBXS',                $mod->package_name, '0.01' ],
  80         'EUNOXS/Foo-Bar-EU-NOXS-0.09'
  81                 => [ 'EUNOXS',              $mod->package_name, '0.09' ],
  82         'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip'
  83                 => [ 'EUNOXS',              $mod->package_name, '0.09' ],
  84         'FROO/Flub-Flob-1.1.zip'
  85                 => [ 'FROO',                'Flub-Flob',        '1.1' ],
  86         'G/GO/GOYALI/SMS_API_3_01.tar.gz'
  87                 => [ 'GOYALI',              'SMS_API',          '3_01' ],
  88         'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091'
  89                 => [ 'EYCK',                'Net-Lite-FTP',     '0.091' ],
  90         'EYCK/Net/Lite/Net-Lite-FTP-0.091'
  91                 => [ 'EYCK',                'Net-Lite-FTP',     '0.091' ],
  92         'M/MA/MAXDB/DBD-MaxDB-7.5.00.24a'
  93                 => [ 'MAXDB',               'DBD-MaxDB',        '7.5.00.24a' ],
  94         'EUNOXS/perl5.005_03.tar.gz'
  95                 => [ 'EUNOXS',              'perl',             '5.005_03' ],
  96         'FROO/Flub-Flob-v1.1.0.tbz'
  97                 => [ 'FROO',                'Flub-Flob',        'v1.1.0' ],
  98         'FROO/Flub-Flob-1.1_2.tbz'
  99                 => [ 'FROO',                'Flub-Flob',        '1.1_2' ],
 100         'LDS/CGI.pm-3.27.tar.gz'
 101                 => [ 'LDS',                 'CGI',              '3.27' ],
 102         'FROO/Text-Tabs+Wrap-2006.1117.tar.gz'
 103                 => [ 'FROO',                'Text-Tabs+Wrap',   '2006.1117' ],
 104         'JETTERO/Crypt-PBC-0.7.20.0-0.4.9',
 105                 => [ 'JETTERO',             'Crypt-PBC',    '0.7.20.0-0.4.9' ],
 106
 107     );
 108
 109     while ( my($guess, $attr) = splice @map, 0, 2 ) {
 110         my( $author, $pkg, $version ) = @$attr;
 111
 112         ok( $guess,             "Attempting to parse $guess" );
 113
 114         my $obj = $cb->parse_module( module => $guess );
 115
 116         ok( $obj,               "   Result returned" );
 117         ok( IS_MODOBJ->( mod => $obj ),
 118                                 "   parse_module success by '$guess'" );
 119
 120         is( $obj->version, $version,
 121                                 "   Proper version found: $version" );
 122         is( $obj->package_version, $version,
 123                                 "       Found in package_version as well" );
 124         is( $obj->package_name, $pkg,
 125                                 "   Proper package found: $pkg" );
 126         unlike( $obj->package_name, qr/\d/,
 127                                 "       No digits in package name" );
 128         like( $obj->author->cpanid, "/$author/i",
 129                                 "   Proper author found: $author");
 130         like( $obj->path,           "/$author/i",
 131                                 "   Proper path found: " . $obj->path );
 132     }
 133
 134
 135     ### test for things that look like real modules, but aren't ###
 136     {   local $CPANPLUS::Error::MSG_FH    = output_handle() if $Trap_Output;
 137         local $CPANPLUS::Error::ERROR_FH  = output_handle() if $Trap_Output;
 138
 139         my @map = (
 140             [  $Name . $$ => [
 141                 [qr/does not contain an author/,"Missing author part detected"],
 142                 [qr/Cannot find .+? in the module tree/,"Unable to find module"]
 143             ] ],
 144             [ {}, => [
 145                 [ qr/module string from reference/,"Unable to parse ref"]
 146             ] ],
 147         );
 148
 149         for my $entry ( @map ) {
 150             my($mod,$aref) = @$entry;
 151
 152             my $none = $cb->parse_module( module => $mod );
 153             ok( !IS_MODOBJ->(mod => $none),
 154                                 "Non-existant module detected" );
 155             ok( !IS_FAKE_MODOBJ->(mod => $none),
 156                                 "Non-existant fake module detected" );
 157
 158             my $str = CPANPLUS::Error->stack_as_string;
 159             for my $pair (@$aref) {
 160                 my($re,$diag) = @$pair;
 161                 like( $str, $re,"   $diag" );
 162             }
 163         }
 164     }
 165
 166     ### test parsing of arbitrary URI
 167     for my $guess ( qw[ http://foo/bar.gz
 168                         http://a/b/c/d/e/f/g/h/i/j
 169                         flub://floo ]
 170     ) {
 171         my $obj = $cb->parse_module( module => $guess );
 172         ok( IS_FAKE_MODOBJ->(mod => $obj), "parse_module success by '$guess'" );
 173         is( $obj->status->_fetch_from, $guess,
 174                                             "   Fetch from set ok" );
 175     }
 176 }
 177
 178 ### RV tests ###
 179 {   my $method = 'readme';
 180     my %args   = ( modules => [$Name] );
 181
 182     my $rv = $cb->$method( %args );
 183     ok( IS_RVOBJ->( $rv ),              "Got an RV object" );
 184     ok( $rv->ok,                        "   Overall OK" );
 185     cmp_ok( $rv, '==', 1,               "   Overload OK" );
 186     is( $rv->function, $method,         "   Function stored OK" );
 187     is_deeply( $rv->args, \%args,       "   Arguments stored OK" );
 188     is( $rv->rv->{$Name}, $mod->readme, "   RV as expected" );
 189 }
 190
 191 ### reload_indices tests ###
 192 {
 193     my $file = File::Spec->catfile( $conf->get_conf('base'),
 194                                     $conf->_get_source('mod'),
 195                                 );
 196
 197     ok( $cb->reload_indices( update_source => 0 ),  "Rebuilding trees" );
 198     my $age = -M $file;
 199
 200     ### make sure we are 'newer' on faster machines with a sleep..
 201     ### apparently Win32's FAT isn't granual enough on intervals
 202     ### < 2 seconds, so it may give the same answer before and after
 203     ### the sleep, causing the test to fail. so sleep atleast 2 seconds.
 204     sleep 2;
 205     ok( $cb->reload_indices( update_source => 1 ),
 206                                     "Rebuilding and refetching trees" );
 207     cmp_ok( $age, '>', -M $file,    "    Source file '$file' updated" );
 208 }
 209
 210 ### flush tests ###
 211 {
 212     for my $cache( qw[methods hosts modules lib all] ) {
 213         ok( $cb->flush($cache), "Cache $cache flushed ok" );
 214     }
 215 }
 216
 217 ### installed tests ###
 218 {
 219     ok( scalar $cb->installed,    "Found list of installed modules" );
 220 }
 221
 222 ### autobudle tests ###
 223 {
 224     my $where = $cb->autobundle;
 225     ok( $where,     "Autobundle written" );
 226     ok( -s $where,  "   File has size" );
 227 }
 228
 229 ### local_mirror tests ###
 230 {   ### turn off md5 checks for the 'fake' packages we have
 231     my $old_md5 = $conf->get_conf('md5');
 232     $conf->set_conf( md5 => 0 );
 233
 234     ### otherwise 'status->fetch' might be undef! ###
 235     my $rv = $cb->local_mirror( path => 'dummy-localmirror' );
 236     ok( $rv,                        "Local mirror created" );
 237
 238     for my $mod ( values %{ $cb->module_tree } ) {
 239         my $name    = $mod->module;
 240
 241         my $cksum   = File::Spec->catfile(
 242                         dirname($mod->status->fetch),
 243                         CHECKSUMS );
 244         ok( -e $mod->status->fetch, "   Module '$name' fetched" );
 245         ok( -s _,                   "       Module '$name' has size" );
 246         ok( -e $cksum,              "   Checksum fetched for '$name'" );
 247         ok( -s _,                   "       Checksum for '$name' has size" );
 248     }
 249
 250     $conf->set_conf( md5 => $old_md5 );
 251 }
 252
 253 ### check ENV variable
 254 {   ### process id
 255     {   my $name = 'PERL5_CPANPLUS_IS_RUNNING';
 256         ok( $ENV{$name},            "Env var '$name' set" );
 257         is( $ENV{$name}, $$,        "   Set to current process id" );
 258     }
 259
 260     ### Version
 261     {   my $name = 'PERL5_CPANPLUS_IS_VERSION';
 262         ok( $ENV{$name},            "Env var '$name' set" );
 263
 264         ### version.pm formats ->VERSION output... *sigh*
 265         is( $ENV{$name}, $Class->VERSION,
 266                                     "   Set to current process version" );
 267     }
 268
 269 }
 270
 271 __END__
 272
 273 # Local variables:
 274 # c-indentation-style: bsd
 275 # c-basic-offset: 4
 276 # indent-tabs-mode: nil
 277 # End:
 278 # vim: expandtab shiftwidth=4:
 279