default.pm

source of perl for linux application,

    if( !$flag ) {
        $self->__print(
            loc("No errors %tense(%1,present) all modules", $action), "\n"
        );
    } else {
        $self->__print(
            loc("Problem %tense(%1,present) one or more modules", $action)
        );
        $self->__print( "\n" );
        
        $self->__print( 
            loc("*** You can view the complete error buffer by pressing ".
                "'%1' ***\n", 'p')
        ) unless $conf->get_conf('verbose') || $self->noninteractive;
    }
    $self->__print( "\n" );

    return !$flag;
}

sub __ask_about_install {
    my $mod     = shift or return;
    my $prereq  = shift or return;
    my $term    = $Shell->term;

    $Shell->__print( "\n" );
    $Shell->__print( loc("Module '%1' requires '%2' to be installed",
                         $mod->module, $prereq->module ) );
    $Shell->__print( "\n\n" );
    $Shell->__print( 
        loc(    "If you don't wish to see this question anymore\n".
                "you can disable it by entering the following ".
                "commands on the prompt:\n    '%1'",
                's conf prereqs 1; s save' ) );
    $Shell->__print("\n\n");

    my $bool =  $term->ask_yn(
                    prompt  => loc("Should I install this module?"),
                    default => 'y'
                );

    return $bool;
}

sub __ask_about_send_test_report {
    my($mod, $grade) = @_;
    return 1 unless $grade eq GRADE_FAIL;

    my $term    = $Shell->term;

    $Shell->__print( "\n" );
    $Shell->__print(
        loc("Test report prepared for module '%1'.\n Would you like to ".
            "send it? (You can edit it if you like)", $mod->module ) );
    $Shell->__print( "\n\n" );
    my $bool =  $term->ask_yn(
                    prompt  => loc("Would you like to send the test report?"),
                    default => 'n'
                );

    return $bool;
}

sub __ask_about_edit_test_report {
    my($mod, $grade) = @_;
    return 0 unless $grade eq GRADE_FAIL;

    my $term    = $Shell->term;

    $Shell->__print( "\n" );
    $Shell->__print( 
        loc("Test report prepared for module '%1'. You can edit this ".
            "report if you would like", $mod->module ) );
    $Shell->__print("\n\n");
    my $bool =  $term->ask_yn(
                    prompt  => loc("Would you like to edit the test report?"),
                    default => 'y'
                );

    return $bool;
}

sub __ask_about_test_failure {
    my $mod         = shift;
    my $captured    = shift || '';
    my $term        = $Shell->term;

    $Shell->__print( "\n" );
    $Shell->__print( 
        loc(    "The tests for '%1' failed. Would you like me to proceed ".
                "anyway or should we abort?", $mod->module ) );
    $Shell->__print( "\n\n" );
    
    my $bool =  $term->ask_yn(
                    prompt  => loc("Proceed anyway?"),
                    default => 'n',
                );

    return $bool;
}


sub _details {
    my $self    = shift;
    my $cb      = $self->backend;
    my $conf    = $cb->configure_object;
    my %hash    = @_;

    my $args; my $mods; my $opts;
    {   local $Params::Check::ALLOW_UNKNOWN = 1;

        my $tmpl = {
            modules => { required => 1,  store => \$mods },
            options => { default => { }, store => \$opts },
        };

        $args = check( $tmpl, \%hash ) or return;
    }

    ### every module has about 10 lines of details
    ### maybe more later with Module::CPANTS etc
    $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount;


    my $format = "%-30s %-30s\n";
    for my $mod (@$mods) {
        my $href = $mod->details( %$opts );
        my @list = sort { $a->module cmp $b->module } $mod->contains;

        unless( $href ) {
            $self->__print( 
                loc("No details for %1 - it might be outdated.",
                    $mod->module), "\n" );
            next;

        } else {
            $self->__print( loc( "Details for '%1'\n", $mod->module ) );
            for my $item ( sort keys %$href ) {
                $self->__printf( $format, $item, $href->{$item} );
            }
            
            my $showed;
            for my $item ( @list ) {
                $self->__printf(
                    $format, ($showed ? '' : 'Contains:'), $item->module
                );
                $showed++;
            }
            $self->__print( "\n" );
        }
    }
    $self->_pager_close;
    $self->__print( "\n" );

    return 1;
}

sub _print {
    my $self = shift;
    my %hash = @_;

    my $args; my $opts; my $file;
    {   local $Params::Check::ALLOW_UNKNOWN = 1;

        my $tmpl = {
            options => { default => { }, store => \$opts },
            input   => { default => '',  store => \$file },
        };

        $args = check( $tmpl, \%hash ) or return;
    }

    my $old; my $fh;
    if( $file ) {
        $fh = FileHandle->new( ">$file" )
                    or( warn loc("Could not open '%1': '%2'", $file, $!),
                        return
                    );
        $old = select $fh;
    }


    $self->_pager_open if !$file;

    $self->__print( CPANPLUS::Error->stack_as_string );

    $self->_pager_close;

    select $old if $old;
    $self->__print( "\n" );

    return 1;
}

sub _set_conf {
    my $self    = shift;
    my %hash    = @_;
    my $cb      = $self->backend;
    my $conf    = $cb->configure_object;

    ### possible options
    ### XXX hard coded, not optimal :(
    my %types   = (
        reconfigure => '', 
        save        => q([user | system | boxed]),
        edit        => '',
        program     => q([key => val]),
        conf        => q([key => val]),
        mirrors     => '',
        selfupdate  => '',  # XXX add all opts here?
    );


    my $args; my $opts; my $input;
    {   local $Params::Check::ALLOW_UNKNOWN = 1;

        my $tmpl = {
            options => { default => { }, store => \$opts },
            input   => { default => '',  store => \$input },
        };

        $args = check( $tmpl, \%hash ) or return;
    }

    my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)\s*$/;
    $type = lc $type;

    if( $type eq 'reconfigure' ) {
        my $setup = CPANPLUS::Configure::Setup->new(
                        configure_object    => $conf,
                        term                => $self->term,
                        backend             => $cb,
                    );
        return $setup->init;

    } elsif ( $type eq 'save' ) {
        my $where = {
            user    => CONFIG_USER,
            system  => CONFIG_SYSTEM,
            boxed   => CONFIG_BOXED,
        }->{ $key } || CONFIG_USER;      
        
        ### boxed is special, so let's get it's value from %INC
        ### so we can tell it where to save
        ### XXX perhaps this logic should be generic for all
        ### types, and put in the ->save() routine
        my $dir;
        if( $where eq CONFIG_BOXED ) {
            my $file    = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm';
            my $file_re = quotemeta($file);
            
            my $path    = $INC{$file} || '';
            $path       =~ s/$file_re$//;        
            $dir        = $path;
        }     
        
        my $rv = $cb->configure_object->save( $where => $dir );

        $self->__print( 
            $rv
                ? loc("Configuration successfully saved to %1\n    (%2)\n",
                       $where, $rv)
                : loc("Failed to save configuration\n" )
        );
        return $rv;

    } elsif ( $type eq 'edit' ) {

        my $editor  = $conf->get_program('editor')
                        or( print(loc("No editor specified")), return );

        my $where = {
            user    => CONFIG_USER,
            system  => CONFIG_SYSTEM,
        }->{ $key } || CONFIG_USER;      
        
        my $file = $conf->_config_pm_to_file( $where );
        system("$editor $file");

        ### now reload it
        ### disable warnings for this
        {   require Module::Loaded;
            Module::Loaded::mark_as_unloaded( $_ ) for $conf->configs;

            ### reinitialize the config
            local $^W;
            $conf->init;
        }

        return 1;

    } elsif ( $type eq 'mirrors' ) {
    
        $self->__print( 
            loc("Readonly list of mirrors (in order of preference):\n\n" ) );
        
        my $i;
        for my $host ( @{$conf->get_conf('hosts')} ) {
            my $uri = $cb->_host_to_uri( %$host );
            
            $i++;
            $self->__print( "\t[$i] $uri\n" );
        }

    } elsif ( $type eq 'selfupdate' ) {
        my %valid = map { $_ => $_ } 
                        $cb->selfupdate_object->list_categories;    

        unless( $valid{$key} ) {
            $self->__print(
                loc( "To update your current CPANPLUS installation, ".
                        "choose one of the these options:\n%1",
                        ( join $/, map { 
                             sprintf "\ts selfupdate %-17s " .
                                     "[--latest=0] [--dryrun]", $_ 
                          } sort keys %valid ) 
                    )
            );          
        } else {
            my %update_args = (
                update  => $key,
                latest  => 1,
                %$opts
            );


            my %list = $cb->selfupdate_object
                            ->list_modules_to_update( %update_args );

            $self->__print(loc("The following updates will take place:"),$/.$/);
            
            for my $feature ( sort keys %list ) {
                my $aref = $list{$feature};
                
                ### is it a 'feature' or a built in?
                $self->__print(
                    $valid{$feature} 
                        ? "  " . ucfirst($feature) . ":\n"
                        : "  Modules for '$feature' support:\n"
                );
                    
                ### show what modules would be installed    
                $self->__print(
                    scalar @$aref
                        ? map { sprintf "    %-42s %-6s -> %-6s \n", 
                                $_->name, $_->installed_version, $_->version
                          } @$aref      
                        : "    No upgrades required\n"
                );                                                  
                $self->__print( $/ );
            }
            
        
            unless( $opts->{'dryrun'} ) { 
                $self->__print( loc("Updating your CPANPLUS installation\n") );
                $cb->selfupdate_object->selfupdate( %update_args );
            }
        }
        
    } else {

        if ( $type eq 'program' or $type eq 'conf' ) {

            my $format = {
                conf    => '%-25s %s',
                program => '%-12s %s',
            }->{ $type };      

            unless( $key ) {
                my @list =  grep { $_ ne 'hosts' }
                            $conf->options( type => $type );

                my $method = 'get_' . $type;

                local $Data::Dumper::Indent = 0;
                for my $name ( @list ) {
                    my $val = $conf->$method($name) || '';
                    ($val)  = ref($val)
                                ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
                                : "'$val'";

                    $self->__printf( "    $format\n", $name, $val );
                }

            } elsif ( $key eq 'hosts' ) {
                $self->__print( 
                    loc(  "Setting hosts is not trivial.\n" .
                          "It is suggested you use '%1' and edit the " .
                          "configuration file manually", 's edit')
                );
            } else {
                my $method = 'set_' . $type;
                $conf->$method( $key => defined $value ? $value : '' )
                    and $self->__print( loc("Key '%1' was set to '%2'", $key,
                                  defined $value ? $value : 'EMPTY STRING') );
            }

        } else {
            $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) );
            $self->__print( $/ );
            $self->__print( loc("Try one of the following:") );
            $self->__print( $/, join $/, 
                      map { sprintf "\t%-11s %s", $_, $types{$_} } 
                      sort keys %types );
        }
    }
    $self->__print( "\n" );
    return 1;
}

sub _uptodate {
    my $self = shift;
    my %hash = @_;
    my $cb   = $self->backend;
    my $conf = $cb->configure_object;

    my $opts; my $mods;
    {   local $Params::Check::ALLOW_UNKNOWN = 1;

        my $tmpl = {
            options => { default => { }, store => \$opts },
            modules => { required => 1,  store => \$mods },
        };

        check( $tmpl, \%hash ) or return;
    }

    ### long listing? short is default ###
    my $long = $opts->{'long'} ? 1 : 0;

    my @list = scalar @$mods ? @$mods : @{$cb->_all_installed};

    my @rv; my %seen;
    for my $mod (@list) {
        ### skip this mod if it's up to date ###
        next if $mod->is_uptodate;
        ### skip this mod if it's core ###
        next if $mod->package_is_perl_core;

        if( $long or !$seen{$mod->package}++ ) {
            push @rv, $mod;
        }
    }

    @rv = sort { $a->module cmp $b->module } @rv;

    $self->cache([undef,@rv]);

    $self->_pager_open if scalar @rv >= $self->_term_rowcount;

    my $format = "%5s %12s %12s %-36s %-10s\n";

    my $i = 1;
    for my $mod ( @rv ) {
        $self->__printf(
            $format,
            $i,
            $self->_format_version($mod->installed_version) || 'Unparsable',
            $self->_format_version( $mod->version ),
            $mod->module,
            $mod->author->cpanid
        );
        $i++;
    }
    $self->_pager_close;