classic.pm

source of perl for linux application,

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

    my $type = shift @$aref;

    if( $type eq 'debug' ) {
        print   qq[Sorry you cannot set debug options through ] .
                qq[this shell in CPANPLUS\n];
        return;

    } elsif ( $type eq 'conf' ) {

        ### from CPAN.pm :o)
        # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
        # should have been called set and 'o debug' maybe 'set debug'

        #    commit             Commit changes to disk
        #    defaults           Reload defaults from disk
        #    init               Interactive setting of all options

        my $name    = shift @$aref;
        my $value   = "@$aref";

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

        } elsif ($name eq 'commit' ) {;
            $cb->configure_object->save;
            print "Your CPAN++ configuration info has been saved!\n\n";
            return;

        } elsif ($name eq 'defaults' ) {
            print   qq[Sorry, CPANPLUS cannot restore default for you.\n] .
                    qq[Perhaps you should run the interactive setup again.\n] .
                    qq[\ttry running 'o conf init'\n];
            return;

        ### we're just supplying things in the 'conf' section now,
        ### not the program section.. it's a bit of a hassle to make that
        ### work cleanly with the original CPAN.pm interface, so we'll fix
        ### it when people start complaining, which is hopefully never.
        } else {
            unless( $name ) {
                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'";
                    printf  "    %-25s %s\n", $name, $val;
                }

            } elsif ( $name eq 'hosts' ) {
                print   "Setting hosts is not trivial.\n" .
                        "It is suggested you edit the " .
                        "configuration file manually";

            } else {
                my $method = 'set_' . $type;
                if( $conf->$method($name => defined $value ? $value : '') ) {
                    my $set_to = defined $value ? $value : 'EMPTY STRING';
                    print "Key '$name' was set to '$set_to'\n";
                }
            }
        }
    } else {
        print   qq[Known options:\n] .
                qq[  conf    set or get configuration variables\n] .
                qq[  debug   set or get debugging options\n];
    }

    return;
}

########################
### search functions ###
########################

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

    my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Author', no_override => 1,
                    store => \$class },
    };

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

    my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref;


    my @rv;
    for my $type (qw[author cpanid]) {
        push @rv, $cb->search( type => $type, allow => \@regexes );
    }

    unless( @rv ) {
        print "No object of type $class found for argument $input\n"
            unless $short;
        return;
    }

    return $self->_pp_author(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );

}

### find all modules matching a query ###
sub _module {
    my $self = shift;
    my $cb   = $self->backend;
    my %hash = @_;

    my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Module', no_override => 1,
                    store => \$class },
    };

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

    my @rv;
    for my $module (@$aref) {
        if( $module =~ m|/(.+)/| ) {
            push @rv, $cb->search(  type    => 'module',
                                    allow   => [qr/$1/i] );
        } else {
            my $obj = $cb->module_tree( $module ) or next;
            push @rv, $obj;
        }
    }

    return $self->_pp_module(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );
}

### find all bundles matching a query ###
sub _bundle {
    my $self = shift;
    my $cb   = $self->backend;
    my %hash = @_;

    my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Bundle', no_override => 1,
                    store => \$class },
    };

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

    my @rv;
    for my $bundle (@$aref) {
        if( $bundle =~ m|/(.+)/| ) {
            push @rv, $cb->search(  type    => 'module',
                                    allow   => [qr/Bundle::.*?$1/i] );
        } else {
            my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next;
            push @rv, $obj;
        }
    }

    return $self->_pp_module(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );
}

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

    my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Distribution', no_override => 1,
                    store => \$class },
    };

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

    my @rv;
    for my $module (@$aref) {
        ### if it's a regex... ###
        if ( my ($match) = $module =~ m|^/(.+)/$|) {

            ### something like /FOO/Bar.tar.gz/ was entered
            if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) {
                my $seen;

                my @data = $cb->search( type    => 'package',
                                        allow   => [qr/$package/i] );

                my @list = $cb->search( type    => 'path',
                                        allow   => [qr/$path/i],
                                        data    => \@data );

                ### make sure we dont list the same dist twice
                for my $val ( @list ) {
                    next if $seen->{$val->package}++;

                    push @rv, $val;
                }

            ### something like /FOO/ or /Bar.tgz/ was entered
            ### so we look both in the path, as well as in the package name
            } else {
                my $seen;
                {   my @list = $cb->search( type    => 'package',
                                            allow   => [qr/$match/i] );

                    ### make sure we dont list the same dist twice
                    for my $val ( @list ) {
                        next if $seen->{$val->package}++;

                        push @rv, $val;
                    }
                }

                {   my @list = $cb->search( type    => 'path',
                                            allow   => [qr/$match/i] );

                    ### make sure we dont list the same dist twice
                    for my $val ( @list ) {
                        next if $seen->{$val->package}++;

                        push @rv, $val;
                    }

                }
            }

        } else {

            ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz
            if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) {
                my @data = $cb->search( type    => 'package',
                                        allow   => [qr/^$package$/] );
                my @list = $cb->search( type    => 'path',
                                        allow   => [qr/$path$/i],
                                        data    => \@data);

                ### make sure we dont list the same dist twice
                my $seen;
                for my $val ( @list ) {
                    next if $seen->{$val->package}++;

                    push @rv, $val;
                }
            }
        }
    }

    return $self->_pp_distribution(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );
}

sub _find_all {
    my $self = shift;

    my @rv;
    for my $method (qw[_author _bundle _module _distribution]) {
        my $aref = $self->$method( @_, short => 1 );

        push @rv, @$aref if $aref;
    }

    print scalar(@rv). " items found\n"
}

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

    my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Uptodate', no_override => 1,
                    store => \$class },
    };

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


    my @rv;
    if( @$aref) {
        for my $module (@$aref) {
            if( $module =~ m|/(.+)/| ) {
                my @list = $cb->search( type    => 'module',
                                        allow   => [qr/$1/i] );

                ### only add those that are installed and not core
                push @rv, grep { not $_->package_is_perl_core }
                          grep { $_->installed_file }
                          @list;

            } else {
                my $obj = $cb->module_tree( $module ) or next;
                push @rv, $obj;
            }
        }
    } else {
        @rv = @{$cb->_all_installed};
    }

    return $self->_pp_uptodate(
            result  => \@rv,
            class   => $class,
            short   => $short,
            input   => $input );
}

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

    my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Uptodate', no_override => 1,
                    store => \$class },
    };

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

    my @rv;
    for my $name (@$aref) {
        my $auth = $cb->author_tree( uc $name );

        unless( $auth ) {
            print qq[ls command rejects argument $name: not an author\n];
            next;
        }

        push @rv, $auth->distributions;
    }

    return $self->_pp_ls(
            result  => \@rv,
            class   => $class,
            short   => $short,
            input   => $input );
}

############################
### pretty printing subs ###
############################


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

    my( $aref, $short, $class, $input );
    my $tmpl = {
        result  => { required => 1, default => [], strict_type => 1,
                        store => \$aref },
        short   => { default => 0, store => \$short },
        class   => { required => 1, store => \$class },
        input   => { required => 1, store => \$input },
    };

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

    ### no results
    if( !@$aref ) {
        print "No objects of type $class found for argument $input\n"
            unless $short;

    ### one result, long output desired;
    } elsif( @$aref == 1 and !$short ) {

        ### should look like this: