default.pm

source of perl for linux application,

    return 1;
}

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

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

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

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

    $opts->{'path'} = $input if $input;

    my $where = $cb->autobundle( %$opts );

    $self->__print( 
        $where
            ? loc("Wrote autobundle to '%1'", $where)
            : loc("Could not create autobundle" )
    );
    $self->__print( "\n" );

    return $where ? 1 : 0;
}

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

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

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

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

    my $force = $opts->{'force'} || $conf->get_conf('force');

    unless( $force ) {
        my $list = join "\n", map { '    ' . $_->module } @$mods;

        $self->__print( loc("
This will uninstall the following modules:
%1

Note that if you installed them via a package manager, you probably
should use the same package manager to uninstall them

", $list) );

        return unless $term->ask_yn(
                        prompt  => loc("Are you sure you want to continue?"),
                        default => 'n',
                    );
    }

    ### first loop over all the modules to uninstall them ###
    for my $mod (@$mods) {
        $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" );

        $mod->uninstall( %$opts );
    }

    my $flag;
    ### then report whether all this went ok or not ###
    for my $mod (@$mods) {
        if( $mod->status->uninstall ) {
            $self->__print( 
                loc("Module '%1' %tense(uninstall,past) successfully\n",
                    $mod->module ) );
        } else {
            $flag++;
            $self->__print( 
                loc("Error %tense(uninstall,present) '%1'\n", $mod->module) );
        }
    }

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

    return !$flag;
}

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

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

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

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

    ### XXX might need to be conditional ###
    $self->_pager_open;

    for my $mod (@$mods) {
        my @list = $mod->fetch_report( %$opts )
                    or( print(loc("No reports available for this distribution.")),
                        next
                    );

        @list = reverse
                map  { $_->[0] }
                sort { $a->[1] cmp $b->[1] }
                map  { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list;



        ### XXX this may need to be sorted better somehow ###
        my $url;
        my $format = "%8s %s %s\n";

        my %seen;
        for my $href (@list ) {
            $self->__print( 
                "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n"
            ) unless $seen{ $href->{'dist'} }++;

            $self->__printf( 
                $format, 
                $href->{'grade'}, 
                $href->{'platform'},
                ($href->{'details'} ? '(*)' : '')
            );

            $url ||= $href->{'details'};
        }

        $self->__print( "\n==> $url\n" ) if $url;
        $self->__print( "\n" );
    }
    $self->_pager_close;

    return 1;
}


### Load plugins
{   my @PluginModules;
    my %Dispatch = ( 
        showtip => [ __PACKAGE__, '_show_random_tip'], 
        plugins => [ __PACKAGE__, '_list_plugins'   ], 
        '?'     => [ __PACKAGE__, '_plugins_usage'  ],
    );        

    sub plugin_modules  { return @PluginModules }
    sub plugin_table    { return %Dispatch }
    
    my $init_done;
    sub _plugins_init {
        ### only initialize once
        return if $init_done++;
        
        ### find all plugins first
        if( check_install( module  => 'Module::Pluggable', version => '2.4') ) {
            require Module::Pluggable;
    
            my $only_re = __PACKAGE__ . '::Plugins::\w+$';
    
            Module::Pluggable->import(
                            sub_name    => '_plugins',
                            search_path => __PACKAGE__,
                            only        => qr/$only_re/,
                            #except      => [ INSTALLER_MM, INSTALLER_SAMPLE ]
                        );
                        
            push @PluginModules, __PACKAGE__->_plugins;
        }
    
        ### now try to load them
        for my $p ( __PACKAGE__->plugin_modules ) {
            my %map = eval { load $p; $p->import; $p->plugins };
            error(loc("Could not load plugin '$p': $@")), next if $@;
        
            ### register each plugin
            while( my($name, $func) = each %map ) {
                
                if( not length $name or not length $func ) {
                    error(loc("Empty plugin name or dispatch function detected"));
                    next;
                }                
                
                if( exists( $Dispatch{$name} ) ) {
                    error(loc("'%1' is already registered by '%2'", 
                        $name, $Dispatch{$name}->[0]));
                    next;                    
                }
        
                ### register name, package and function
                $Dispatch{$name} = [ $p, $func ];
            }
        }
    }
    
    ### dispatch a plugin command to it's function
    sub _meta {
        my $self = shift;
        my %hash = @_;
        my $cb   = $self->backend;
        my $term = $self->term;
        my $conf = $cb->configure_object;
    
        my $opts; my $input;
        {   local $Params::Check::ALLOW_UNKNOWN = 1;
    
            my $tmpl = {
                options => { default => { }, store => \$opts },
                input   => { default => '',  store => \$input },
            };
    
             check( $tmpl, \%hash ) or return;
        }
    
        $input =~ s/\s*(\S+)\s*//;
        my $cmd = $1;
    
        ### look up the command, or go to the default
        my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ];
        
        my($pkg,$func) = @$aref;
        
        my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) };
        
        error( $@ ) if $@;

        ### return $rv instead, so input loop can be terminated?
        return 1;
    }
    
    sub _plugin_default { error(loc("No such plugin command")) }
}

### plugin commands 
{   my $help_format = "    /%-21s # %s\n"; 
    
    sub _list_plugins   {
        my $self = shift;
        
        $self->__print( loc("Available plugins:\n") );
        $self->__print( loc("    List usage by using: /? PLUGIN_NAME\n" ) );
        $self->__print( $/ );
        
        my %table = __PACKAGE__->plugin_table;
        for my $name( sort keys %table ) {
            my $pkg     = $table{$name}->[0];
            my $this    = __PACKAGE__;
            
            my $who = $pkg eq $this
                ? "Standard Plugin"
                : do { $pkg =~ s/^$this/../; "Provided by: $pkg" };
            
            $self->__printf( $help_format, $name, $who );
        }          
    
        $self->__print( $/.$/ );
        
        $self->__print(
            "    Write your own plugins? Read the documentation of:\n" .
            "        CPANPLUS::Shell::Default::Plugins::HOWTO\n" );
                
        $self->__print( $/ );        
    }

    sub _list_plugins_help {
        return sprintf $help_format, 'plugins', loc("lists available plugins");
    }

    ### registered as a plugin too
    sub _show_random_tip_help {
        return sprintf $help_format, 'showtip', loc("show usage tips" );
    }   

    sub _plugins_usage {
        my $self    = shift;
        my $shell   = shift;
        my $cb      = shift;
        my $cmd     = shift;
        my $input   = shift;
        my %table   = $self->plugin_table;
        
        my @list = length $input ? split /\s+/, $input : sort keys %table;
        
        for my $name( @list ) {

            ### no such plugin? skip
            error(loc("No such plugin '$name'")), next unless $table{$name};

            my $pkg     = $table{$name}->[0];
            my $func    = $table{$name}->[1] . '_help';
            
            if ( my $sub = $pkg->can( $func ) ) {
                eval { $self->__print( $sub->() ) };
                error( $@ ) if $@;
            
            } else {
                $self->__print("    No usage for '$name' -- try perldoc $pkg");
            }
            
            $self->__print( $/ );
        }          
    
        $self->__print( $/.$/ );      
    }
    
    sub _plugins_usage_help {
        return sprintf $help_format, '? [NAME ...]',
                                     loc("show usage for plugins");
    }
}

### send a command to a remote host, retrieve the answer;
sub __send_remote_command {
    my $self    = shift;
    my $cmd     = shift;
    my $remote  = $self->remote or return;
    my $user    = $remote->{'username'};
    my $pass    = $remote->{'password'};
    my $conn    = $remote->{'connection'};
    my $end     = "\015\012";
    my $answer;

    my $send = join "\0", $user, $pass, $cmd;

    print $conn $send . $end;

    ### XXX why doesn't something like this just work?
    #1 while recv($conn, $answer, 1024, 0);
    while(1) {
        my $buff;
        $conn->recv( $buff, 1024, 0 );
        $answer .= $buff;
        last if $buff =~ /$end$/;
    }

    my($status,$buffer) = split "\0", $answer;

    return ($status, $buffer);
}


sub _read_configuration_from_rc {
    my $self    = shift;
    my $rc_file = shift;

    my $href;
    if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) {
        $Config::Auto::DisablePerl = 1;

        eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) };

        $self->__print( 
            loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) 
        ) if $@;
    }

    return $href || {};
}

{   my @tips = (
        loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ),
        loc( "You can install modules by URL using '%1'", 'i URL' ),
        loc( "You can turn off these tips using '%1'", 
             's conf show_startup_tip 0' ),
        loc( "You can use wildcards like '%1' and '%2' on search results",
             '*', '2..5' ) ,
        loc( "You can use plugins. Type '%1' to list available plugins",
             '/plugins' ),
        loc( "You can show all your out of date modules using '%1'", 'o' ),  
        loc( "Many operations take options, like '%1', '%2' or '%3'",
             '--verbose', '--force', '--skiptest' ),
        loc( "The documentation in %1 and %2 is very useful",
             "CPANPLUS::Module", "CPANPLUS::Backend" ),
        loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ),
        loc( "You can run an interactive setup using '%1'", 's reconfigure' ),    
        loc( "You can add custom sources to your index. See '%1' for details",
             '/cs --help' ),
    );
    
    sub _show_random_tip {
        my $self = shift;
        $self->__print( $/, "Did you know...\n    ", 
                        $tips[ int rand scalar @tips ], $/ );
        return 1;
    }
}    

1;

__END__

=pod

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>[e-mail]<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>[e-mail]<gt>.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E<lt>[e-mail]<gt>. All rights reserved.

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=head1 SEE ALSO

L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp>

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:

__END__

TODO:
    e   => "_expand_inc", # scratch it, imho -- not used enough

### free letters: g j k n y ###