classic.pm

source of perl for linux application,

        #cpan> a KANE
        #Author id = KANE
        #    EMAIL        [e-mail]
        #    FULLNAME     Jos Boumans

        my $obj = shift @$aref;

        print "$class id = ",                   $obj->cpanid(), "\n";
        printf "    %-12s %s\n", 'EMAIL',       $obj->email();
        printf "    %-12s %s%s\n", 'FULLNAME',  $obj->author();

    } else {

        ### should look like this:
        #Author          KANE (Jos Boumans)
        #Author          LBROCARD (Leon Brocard)
        #2 items found

        for my $obj ( @$aref ) {
            printf qq[%-15s %s ("%s" (%s))\n],
                $class, $obj->cpanid, $obj->author, $obj->email;
        }
        print scalar(@$aref)." items found\n" unless $short;
    }

    return $aref;
}

sub _pp_module {
    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:
        #Module id = LWP
        #    DESCRIPTION  Libwww-perl
        #    CPAN_USERID  GAAS (Gisle Aas <[e-mail]>)
        #    CPAN_VERSION 5.64
        #    CPAN_FILE    G/GA/GAAS/libwww-perl-5.64.tar.gz
        #    DSLI_STATUS  RmpO (released,mailing-list,perl,object-oriented)
        #    MANPAGE      LWP - The World-Wide Web library for Perl
        #    INST_FILE    C:\Perl\site\lib\LWP.pm
        #    INST_VERSION 5.62

        my $obj     = shift @$aref;
        my $aut_obj = $obj->author;
        my $format  = "    %-12s %s%s\n";

        print "$class id = ",           $obj->module(), "\n";
        printf $format, 'DESCRIPTION',  $obj->description()
            if $obj->description();

        printf $format, 'CPAN_USERID',  $aut_obj->cpanid() . " (" .
            $aut_obj->author() . " <" . $aut_obj->email() . ">)";

        printf $format, 'CPAN_VERSION', $obj->version();
        printf $format, 'CPAN_FILE',    $obj->path() . '/' . $obj->package();

        printf $format, 'DSLI_STATUS',  $self->_pp_dslip($obj->dslip)
            if $obj->dslip() =~ /\w/;

        #printf $format, 'MANPAGE',      $obj->foo();
        ### this is for bundles... CPAN.pm downloads them,
        #printf $format, 'CONATAINS,
        # parses and goes from there...

        printf $format, 'INST_FILE',    $obj->installed_file ||
            '(not installed)';
        printf $format, 'INST_VERSION', $obj->installed_version;



    } else {

        ### should look like this:
        #Module          LWP             (G/GA/GAAS/libwww-perl-5.64.tar.gz)
        #Module          POE             (R/RC/RCAPUTO/POE-0.19.tar.gz)
        #2 items found

        for my $obj ( @$aref ) {
            printf "%-15s %-15s (%s)\n", $class, $obj->module(),
                $obj->path() .'/'. $obj->package();
        }
        print scalar(@$aref). " items found\n" unless $short;
    }

    return $aref;
}

sub _pp_dslip {
    my $self    = shift;
    my $dslip   = shift or return;

    my (%_statusD, %_statusS, %_statusL, %_statusI);

    @_statusD{qw(? i c a b R M S)} =
        qw(unknown idea pre-alpha alpha beta released mature standard);

    @_statusS{qw(? m d u n)}       =
        qw(unknown mailing-list developer comp.lang.perl.* none);

    @_statusL{qw(? p c + o h)}     = qw(unknown perl C C++ other hybrid);
    @_statusI{qw(? f r O h)}       =
        qw(unknown functions references+ties object-oriented hybrid);

    my @status = split("", $dslip);

    my $results = sprintf( "%s (%s,%s,%s,%s)",
        $dslip,
        $_statusD{$status[0]},
        $_statusS{$status[1]},
        $_statusL{$status[2]},
        $_statusI{$status[3]}
    );

    return $results;
}

sub _pp_distribution {
    my $self = shift;
    my $cb   = $self->backend;
    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:
        #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz
        #    CPAN_USERID  SABECK (Scott Beck <[e-mail]>)
        #    CONTAINSMODS POE::Component::Client::POP3

        my $obj     = shift @$aref;
        my $aut_obj = $obj->author;
        my $pkg     = $obj->package;
        my $format  = "    %-12s %s\n";

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


        print "$class id = ", $obj->path(), '/', $obj->package(), "\n";
        printf $format, 'CPAN_USERID',
                    $aut_obj->cpanid .' ('. $aut_obj->author .
                    ' '. $aut_obj->email .')';

        ### yes i know it's ugly, but it's what cpan.pm does
        printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list);

    } else {

        ### should look like this:
        #Distribution    LWP             (G/GA/GAAS/libwww-perl-5.64.tar.gz)
        #Distribution    POE             (R/RC/RCAPUTO/POE-0.19.tar.gz)
        #2 items found

        for my $obj ( @$aref ) {
            printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package();
        }

        print scalar(@$aref). " items found\n" unless $short;
    }

    return $aref;
}

sub _pp_uptodate {
    my $self = shift;
    my $cb   = $self->backend;
    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;

    my $format  = "%-25s %9s %9s  %s\n";

    my @not_uptodate;
    my $no_version;

    my %seen;
    for my $mod (@$aref) {
        next if $mod->package_is_perl_core;
        next if $seen{ $mod->package }++;


        if( $mod->installed_file and not $mod->installed_version ) {
            $no_version++;
            next;
        }

        push @not_uptodate, $mod unless $mod->is_uptodate;
    }

    unless( @not_uptodate ) {
        my $string = $input
                        ? "for $input"
                        : '';
        print "All modules are up to date $string\n";
        return;

    } else {
        printf $format, (   'Package namespace',
                            'installed',
                            'latest',
                            'in CPAN file'
                        );
    }

    for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) {
        printf $format, (   $mod->module,
                            $mod->installed_version,
                            $mod->version,
                            $mod->path .'/'. $mod->package,
                        );
    }

    print "$no_version installed modules have no (parsable) version number\n"
        if $no_version;

    return \@not_uptodate;
}

sub _pp_ls {
    my $self = shift;
    my $cb   = $self->backend;
    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;

    ### should look something like this:
    #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz
    #8171 2002-08-13 KANE/Acme-Comment-1.01.zip
    #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz
    #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz
    #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip
    #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz

    ### don't know size or mtime
    #my $format = "%8d %10s %s/%s\n";

    for my $mod ( sort { $a->package cmp $b->package } @$aref ) {
        print "\t" . $mod->package . "\n";
    }

    return $aref;
}


#############################
### end pretty print subs ###
#############################


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

    my( $input );
    my $tmpl = {
        input   => { required => 1, store => \$input },
    };

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

    eval $input;
    warn $@ if $@;

    print "\n";

    return;
}

sub _help {
    print qq[
Display Information
 a                                    authors
 b         string           display   bundles
 d         or               info      distributions
 m         /regex/          about     modules
 i         or                         anything of above
 r         none             reinstall recommendations
 u                          uninstalled distributions

Download, Test, Make, Install...
 get                        download
 make                       make (implies get)
 test      modules,         make test (implies make)
 install   dists, bundles   make install (implies test)
 clean                      make clean
 look                       open subshell in these dists' directories
 readme                     display these dists' README files

Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                force cmd     unconditionally do cmd
];

}



1;
__END__

=pod

=head1 NAME

CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS

=head1 DESCRIPTION

The Classic shell is designed to provide the feel of the CPAN.pm shell
using CPANPLUS underneath.

For detailed documentation, refer to L<CPAN>.

=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::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>

=cut


=head1 SEE ALSO

L<CPAN>

=cut



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