lib/CPANPLUS/t/02_CPANPLUS-Internals.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
  10 use CPANPLUS::Configure;
  11 use CPANPLUS::Backend;
  12 use CPANPLUS::Internals::Constants;
  13 use Module::Load::Conditional       qw[can_load];
  14 use Data::Dumper;
  15
  16 my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() );
  17
  18 isa_ok($cb,                 'CPANPLUS::Internals');
  19 is($cb->_id, $cb->_last_id, "Comparing ID's");
  20
  21 ### delete/store/retrieve id tests ###
  22 {   my $del = $cb->_remove_id( $cb->_id );
  23     ok( $del,                   "ID deleted" );
  24     isa_ok( $del,               "CPANPLUS::Internals" );
  25     is( $del, $cb,              "   Deleted ID matches last object" );
  26
  27     my $id = $cb->_store_id( $del );
  28     ok( $id,                    "ID stored" );
  29     is( $id, $cb->_id,          "   Stored proper ID" );
  30
  31     my $obj = $cb->_retrieve_id( $id );
  32     ok( $obj,                   "Object retrieved from ID" );
  33     isa_ok( $obj,               'CPANPLUS::Internals' );
  34     is( $obj->_id, $id,         "   Retrieved ID properly" );
  35
  36     my @obs = $cb->_return_all_objects();
  37     ok( scalar(@obs),           "Returned objects" );
  38     is( scalar(@obs), 1,        "   Proper amount of objects found" );
  39     is( $obs[0]->_id, $id,      "   Proper ID found on object" );
  40
  41     my $lid = $cb->_last_id;
  42     ok( $lid,                   "Found last registered ID" );
  43     is( $lid, $id,              "   ID matches last object" );
  44
  45     my $iid = $cb->_inc_id;
  46     ok( $iid,                   "Incremented ID" );
  47     is( $iid, $id+1,            "   ID matched last ID + 1" );
  48 }
  49
  50 ### host ok test ###
  51 {
  52     my $host = $cb->configure_object->get_conf('hosts')->[0];
  53
  54     is( $cb->_host_ok( host => $host ),     1,  "Host ok" );
  55     is( $cb->_add_fail_host(host => $host), 1,  "   Host now marked as bad" );
  56     is( $cb->_host_ok( host => $host ),     0,  "   Host still bad" );
  57     ok( $cb->_flush( list => ['hosts'] ),       "   Hosts flushed" );
  58     is( $cb->_host_ok( host => $host ),     1,  "   Host now ok again" );
  59 }
  60
  61 ### flush loads test
  62 {   my $mod     = 'Benchmark';
  63     my $file    = $mod . '.pm';
  64
  65     ### XXX whitebox test -- mark this module as unloadable
  66     $Module::Load::Conditional::CACHE->{$mod}->{usable} = 0;
  67
  68     ok( !can_load( modules => { $mod => 0 }, verbose => 0 ),
  69                                                 "'$mod' not loaded" );
  70
  71     ok( $cb->flush('load'),                     "   'load' cache flushed" );
  72     ok( can_load( modules => { $mod => 0 }, verbose => 0 ),
  73                                                 "   '$mod' loaded" );
  74 }
  75
  76 ### add to inc path tests
  77 {   my $meth = '_add_to_includepath';
  78     can_ok( $cb,                $meth );
  79
  80     my $p5lib   = $ENV{PERL5LIB} || '';
  81     my $inc     = "@INC";
  82     ok( $cb->$meth( directories => [$$] ),
  83                                 "   CB->$meth( $$ )" );
  84
  85     my $new_p5lib   = $ENV{PERL5LIB};
  86     my $new_inc     = "@INC";
  87     isnt( $p5lib, $new_p5lib,   "       PERL5LIB is now: $new_p5lib" );
  88     like( $new_p5lib, qr/$$/,   "           Matches $$" );
  89
  90     isnt( $inc, $new_inc,       '       @INC is expanded with: ' . $$ );
  91     like( $new_inc, qr/$$/,     "           Matches $$" );
  92
  93     ok( $cb->$meth( directories => [$$] ),
  94                                 "       CB->$meth( $$ ) again" );
  95     is( "@INC", $new_inc,       '           @INC unchanged' );
  96     is( $new_p5lib, $ENV{PERL5LIB},
  97                                 "           PERL5LIB unchanged" );
  98 }
  99
 100 ### callback registering tests ###
 101 {    my $callback_map = {
 102         ### name                default value
 103         install_prerequisite    => 1,   # install prereqs when 'ask' is set?
 104         edit_test_report        => 0,   # edit the prepared test report?
 105         send_test_report        => 1,   # send the test report?
 106         munge_test_report       => $$,  # munge the test report
 107         filter_prereqs          => $$,  # limit prereqs
 108         proceed_on_test_failure => 0,   # continue on failed 'make test'?
 109         munge_dist_metafile     => $$,  # munge the metailfe
 110     };
 111
 112     for my $callback ( keys %$callback_map ) {
 113
 114         {   my $rv = $callback_map->{$callback};
 115
 116             is( $rv, $cb->_callbacks->$callback->( $0, $$ ),
 117                                 "Default callback '$callback' called" );
 118             like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s,
 119                                 "   Default handler warning recorded" );
 120             CPANPLUS::Error->flush;
 121         }
 122
 123         ### try to register the callback
 124         my $ok = $cb->_register_callback(
 125                         name    => $callback,
 126                         code    => sub { return $callback }
 127                     );
 128
 129         ok( $ok,                "Registered callback '$callback' ok" );
 130
 131         my $sub = $cb->_callbacks->$callback;
 132         ok( $sub,               "   Retrieved callback" );
 133         ok( IS_CODEREF->($sub), "   Callback is a sub" );
 134
 135         my $rv = $sub->();
 136         ok( $rv,                "   Callback called ok" );
 137         is( $rv, $callback,     "   Got expected return value" );
 138     }
 139 }
 140
 141
 142 # Local variables:
 143 # c-indentation-style: bsd
 144 # c-basic-offset: 4
 145 # indent-tabs-mode: nil
 146 # End:
 147 # vim: expandtab shiftwidth=4: