30_cpanplus-internals-selfupdate.t

source of perl for linux application,

### make sure we can find our conf.pl file
BEGIN { 
    use FindBin; 
    require "$FindBin::Bin/inc/conf.pl";
}

use strict;

use CPANPLUS::Backend;
use CPANPLUS::Internals::Constants;
use Test::More 'no_plan';
use Data::Dumper;

my $conf = gimme_conf();
$conf->set_conf( verbose => 0 );

my $Class       = 'CPANPLUS::Selfupdate';
my $ModClass    = "CPANPLUS::Selfupdate::Module";
my $CB          = CPANPLUS::Backend->new( $conf );
my $Acc         = 'selfupdate_object';
my $Conf        = $Class->_get_config;
my $Dep         = TEST_CONF_PREREQ;   # has to be in our package file && core!
my $Feat        = 'some_feature';
my $Prereq      = { $Dep => 0 };

### test the object
{   ok( $CB,                    "New backend object created" );
    can_ok( $CB,                $Acc );

    ok( $Conf,                  "Got configuration hash" );

    my $su = $CB->$Acc;
    ok( $su,                    "Selfupdate object retrieved" );
    isa_ok( $su,                $Class );
}


### check specifically if our bundled shells dont trigger a 
### dependency (see #26077).
### do this _before_ changing the built in conf!
{   my $meth = 'modules_for_feature';
    my $type = 'shell';
    my $cobj = $CB->configure_object;
    my $cur  = $cobj->get_conf( $type );

    for my $shell ( SHELL_DEFAULT, SHELL_CLASSIC ) {
        ok( $cobj->set_conf( $type => $shell ),         
                            "Testing dependencies for '$shell'" );

        my $rv = $CB->$Acc->$meth( $type => 1);
        ok( !$rv,           "   No dependencies for '$shell' -- bundled" );
    }            
    
    for my $shell ( 'CPANPLUS::Test::Shell' ) {
        ok( $cobj->set_conf( $type => $shell ),         
                            "Testing dependencies for '$shell'" );

        my $rv = $CB->$Acc->$meth( $type => 1 );
        ok( $rv,            "   Got prereq hash" );
        isa_ok( $rv,        'HASH',
                            "   Return value" );
        is_deeply( $rv, { $shell => '0.0' },
                            "   With the proper entries" );
    }
}        

### test the feature list
{   ### start with defining our OWN type of config, as not all mentioned
    ### modules will be present in our bundled package files.
    ### XXX WHITEBOX TEST!!!!
    {   delete $Conf->{$_} for keys %$Conf;
        $Conf->{'dependencies'}         = $Prereq;
        $Conf->{'core'}                 = $Prereq;
        $Conf->{'features'}->{$Feat}    = [ $Prereq, sub { 1 } ];
    }

    is_deeply( $Conf, $Class->_get_config,
                                "Config updated succesfully" );

    my @cat  = $CB->$Acc->list_categories;
    ok( scalar(@cat),           "Category list returned" );

    my @feat = $CB->$Acc->list_features;
    ok( scalar(@feat),          "Features list returned" );

    ### test if we get modules for each feature
    for my $feat (@feat) {
        my $meth = 'modules_for_feature';
        my @mods = $CB->$Acc->$meth( $feat );
        
        ok( $feat,              "Testing feature '$feat'" );
        ok( scalar( @mods ),    "   Module list returned" );
    
        my $acc = 'is_installed_version_sufficient';
        for my $mod (@mods) {
            isa_ok( $mod,       "CPANPLUS::Module" );
            isa_ok( $mod,       $ModClass );
            can_ok( $mod,       $acc );
            ok( $mod->$acc,    "   Module uptodate" );
        }                                    
        
        ### check if we can get a hashref
        {   my $href = $CB->$Acc->$meth( $feat, 1 );
            ok( $href,          "Got result as hash" );
            isa_ok( $href,      'HASH' );
            is_deeply( $href, $Prereq,
                                "   With the proper entries" );

        }        
    }

    ### see if we can get a list of modules to be updated
    {   my $cat  = 'core';
        my $meth = 'list_modules_to_update';

        ### XXX just test the mechanics, make sure is_uptodate
        ### returns false
        ### declare twice because warnings are hateful
        ### declare in a block to quelch 'sub redefined' warnings.
        { local *CPANPLUS::Selfupdate::Module::is_uptodate = sub { return }; }
          local *CPANPLUS::Selfupdate::Module::is_uptodate = sub { return };

        my %list = $CB->$Acc->$meth( update => $cat, latest => 1 );

        cmp_ok( scalar(keys(%list)), '==', 1,
                                "Got modules for '$cat' from '$meth'" );
        
        my $aref = $list{$cat};
        ok( $aref,              "   Got module list" );
        cmp_ok( scalar(@$aref), '==', 1,
                                "   With right amount of modules" );
        isa_ok( $aref->[0],     $ModClass );
        is( $aref->[0]->name, $Dep,
                                "   With the right name ($Dep)" );
    }

    ### find enabled features
    {   my $meth = 'list_enabled_features';
        can_ok( $Class,         $meth );        
        
        my @list = $CB->$Acc->$meth;
        ok( scalar(@list),      "Retrieved enabled features" );
        is_deeply( [$Feat], \@list,
                                "   Proper features found" );
    }
    
    ### find dependencies/core modules
    for my $meth ( qw[list_core_dependencies list_core_modules] ) {
        can_ok( $Class,         $meth );        
        
        my @list = $CB->$Acc->$meth;
        ok( scalar(@list),      "Retrieved modules" );
        is( scalar(@list), 1,   "   1 Found" );
        isa_ok( $list[0],       $ModClass ); 
        is( $list[0]->name, $Dep,
                                "   Correct module found" );

        ### check if we can get a hashref
        {   my $href = $CB->$Acc->$meth( 1 );
            ok( $href,          "Got result as hash" );
            isa_ok( $href,      'HASH' );
            is_deeply( $href, $Prereq,
                                "   With the proper entries" );
        }
    }
    

    ### now selfupdate ourselves
    {   ### XXX just test the mechanics, make sure install returns true
        ### declare twice because warnings are hateful
        ### declare in a block to quelch 'sub redefined' warnings.
        { local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; }
          local *CPANPLUS::Selfupdate::Module::install = sub { 1 };
        
        my $meth = 'selfupdate';
        can_ok( $Class,         $meth );
        ok( $CB->$Acc->$meth( update => 'all'),   
                                "   Selfupdate successful" );
    }
}