USAGE: cpannn38.pl [02packages.details.txt | or other valid file]

NAVIGATION:

.  simple list of contained namespaces
.. move one level up
+  detailed list of namespaces directly contained in the current one
++ dump a simple recursive tree of contained namespaces
*  read the readme file of current namespace; needs LWP::UserAgent
** download the current namespace's package; needs LWP::UserAgent
?  print this help

TAB completion, case insensitive, enabled on all sub namespaces

##</code><code>##

#!perl
use strict;
use warnings;
use Data::Dump::Streamer;
# if you wont to modify CPANnn take in consideration using Data::Dump::Streamer on the $cpan hasref
#
# UserAgent and cpan file handle. need to be here before BEGIN block,the file handle for cpan data too
my ( $ua, $cpanfh );
# BEGIN block needed to set some ENV variables
# and to evaluate LWP::UserAgent support
# Also check some contions and set the file handle $cpanfh
# and, eventually the LWP::UserAgent object $ua
BEGIN {
    # WARNING !! string eval in action!!
    # let people to quit
    print "\n\nWARNING: $0 uses string eval!\n"
        ."Use at your own risk!\nENTER to continue or CTRL-C to terminate.\n";
    while (<STDIN>){last if $_ }
    
    local $@;
    # force Term::ReadLine to load the Term::ReadLine::Perl if present
    $ENV{PERL_RL} = "Perl";
    # TAB completion made possible on win32 via Term::Readline with TERM=
    $ENV{TERM}    = 'not dumb' if $^O eq 'MSWin32';
    # evaluate optional LWP::UserAgent support
    eval { require LWP::UserAgent; };
    if ($@) { print "WARNING: no LWP::UserAgent support!" }
    # die if no LWP::UA nor filename given as arg
    if ( $@ and !$ARGV[0] ) {
        die "FATAL: no filename as argument nor LWP::UserAgent support!\n";
    }
    # let's proceed
    $ua = LWP::UserAgent->new;
    # this must go inside BEGIN or assignment is not run
    my $filename =
      defined $ARGV[0]
      ? $ARGV[0]
      : '02packages.details.txt';
    # if we are here we have LWP support
    # so if no filename was given as arg we download it
    if ( !$ARGV[0] ) {
        print "Downloading $filename, please wait..\n";
        $ua->get( 'http://www.cpan.org/modules/' . $filename,
            ':content_file' => $filename );
    }
    # open the file (given or downloaded)
    # and set the filehandle
    open $cpanfh, '<', $filename
      or die "FATAL: unable to open '$filename' for reading!\n";
}
use Term::ReadLine;
my $term = Term::ReadLine->new('CPAN namespace navigator');
# the main cpan hasref, container of all namespaces
my $cpan ={ '.' => 'CPAN' };
# regex used to skip secret hash keys: . .. + ++
my $skiprx = qr/^[\.\+]{1,2}$/;
# used to divide in screenfulls the readme files
my $pagination = 20;
# infos about the file and help too
my @infos      = "\nINFO:\n\n";


# now feed @infos with headers from file 02packages.details.txt
# fetching the cpan file until we reach an empty line
# because after that strat namespaces enumeration
while (<$cpanfh>) {
    print "Processing data, please wait..\n" and last if /^$/;
    push @infos, $_;
}
push @infos, $_
  for "\n\n",
  "USAGE: $0 [02packages.details.txt | or other valid file]\n\nNAVIGATION:\n\n",
  ".  simple list of contained namespaces\n", ".. move one level up\n",
  "+  detailed list of namespaces directly contained in the current one\n",
  "++ dump a simple recursive tree of contained namespaces\n",
  "*  read the readme file of current namespace; needs LWP::UserAgent\n",
  "** download the current namespace's package; needs LWP::UserAgent\n",
  "?  print this help\n",
  "\nTAB completion, case insensitive, enabled on all sub namespaces\n",
  "$0 by Discipulus as found at perlmonks.org\n\n";

# main extrapolation loop
# we go on fetchin the cpan file
# because now there are only namespaces
while (<$cpanfh>) {
    # AA::BB::CC  0.01 D/DI/DISCIPULUS/AA-BB-CC-0.001.tar.gz
    chomp;
    # split namespaces, version, partial path
    my @fields = split /\s+/;
    # split namespace in AA BB CC
    my @names     = split /::/, $fields[0];
    # die if received invalid data              # or is better /\.gz|zip|tgz|bz2$/ ?
    unless (defined $names[0] and $fields[2]=~ /^[A-Z]{1}\/[A-Z]{2}\/[A-Z]+/ ) {
          die "FATAL: no valid data in the file?\nReceived: $_"
              . join ' ',@fields
              ."\n";
    }
    # sanitize names containing ' that seems to valid
    map {s/'/\\'/} @names;
    # @ancestors are @names less last element
    my @ancestors = @names;
    pop @ancestors;
    local $@;
    #
    # evaluate the namespaces in order to build
    # a big hash structure where a namespaces has many key
    # as contained namespaces.
    # additional keys are created to store the name,
    # the parent, and an array with version and partial path
    #
    # start of cpan container; it ends before next = sign
    # AA::BB::CC was splitted in the @names array as:
    # AA BB CC the evaluation transfoms entries in
    # $cpan->{'AA'}{'BB'}{'CC'}
    # but eval autovivifies only BECAUSE there is an assignment: ie:
    # $cpan->{'AA'}{'BB'}{'CC'} =  --hasref with data--
    eval '$cpan->{\''
      . ( join '\'}{\'', @names ) . '\'} ='
      # hasref start
      . '{'
      # hasref . is name and
      . '"."=>$names[-1],' .
      # .. is a ref to father
      # if there is at least one parent
      # now evaluate the path to parent
      # else main cpan hasref is the parent
      '".."=> \%{$cpan'
      . (
        defined $ancestors[0]
        ? '->{\'' . ( join '\'}{\'', @ancestors ) . '\'}'
        : '' )
      . '},'
      # + key is used to store in an array
      # with version and partial path
      . '"+"=> [$fields[1],$fields[2]],'
      .
      # hashref containted in the current key ends here
      '}; ';
      print "WARNING: $@\n\t@fields\n" if $@;
}

# the current hashref namespace starts at top level of the hash
my $current = \%$cpan;
# first time header
&header($current);
# take track of namespaces and, if empty, tell us we are at top level
my @cur_names;

# lines below is the first time initalization for autocompletion
$term->Attribs->{completion_function} = sub {
    my $txt = shift;
    return grep { /^$txt/i } grep $_ !~ $skiprx, sort keys %$current;
};
#
# interactive part of the program
while ( defined( $_ = $term->readline( ( join '::', @cur_names ) . '>' ) ) ) {
    # next on empty lines, chomp input otherwise
    /^$/ ? next : chomp;
    # remove eventual spaces on input
    s/\s+//g;
    # if exists the given (input) key (not matching the skip regex) in
    # the current hashref we set current and cur_names and next cycle
    if ( exists $$current{$_} and $_ !~ $skiprx ) {
        $current = \%{ $$current{$_} };
        push @cur_names, $_;
    }
    # . -> ls
    # print current keys (not matching the skip regex)
    elsif ( $_ eq '.' ) {
        print "$_\n" for grep $_ !~ $skiprx, sort keys %$current;
    }
    # + -> ls -l
    # print current keys (not matching the skip regex)
    # with additional infos: version and partial author's path
    # if such infos are not there, the namespace is a container only one
    elsif ( $_ eq '+' ) {
        foreach my $k ( grep $_ !~ $skiprx, sort keys %$current ) {
            print "$k\t", ${ $current->{$k}{'+'} }[0]
              ? join "\t", @{ $current->{$k}{'+'} }
              : "--CONTAINER NAMESPACE--", "\n";
        }
    }
    # ++ -> tree
    # print current keys (not matching the skip regex)
    # with additional infos: version and partial author's path
    # if such infos are not there, the namespace is a container only one
    elsif ( $_ eq '++' ) {
        &header($current);
        tree_dump($current);
    }
    # .. -> cd ..
    # go up one level in the datastructure
    elsif ( $_ eq '..' ) {
        pop @cur_names;
        $current =
          \%{ eval '$cpan->{\'' . ( join '\'}{\'', @cur_names ) . '\'}'
              || $cpan };
    }
    # * -> dump the readme
    # if LWP::UserAgent is present we fetch the readme file
    # of the current distribution we are navigating.
    # silently skip container only namespaces
    elsif ( $_ eq '*' ) {
        unless ($ua) { print "WARNING: no LWP::UserAgent support!\n"; next; }
        if ( defined $$current{'+'}->[0] ) {
            ( my $url =
                  'http://www.cpan.org/authors/id/' . $$current{'+'}->[1] ) =~
              s/\.tar\.gz/\.readme/;
            my $line_count;
            my $resp = $ua->get($url);
            if ( $resp->is_error ) {
                print "WARNING: ", $resp->status_line, " for $url\n";
                next;
            }
            # rough pagination à la more
            # prints chunks of 20 ($pagination) lines
            foreach my $line ( split "\n", $resp->content() ) {
                ++$line_count;
                print "$line_count:" . $line . "\n";
                if ( $line_count % $pagination == 0 ) {
                    print "-- press Enter to continue..";
                    while (<STDIN>) { last if $_ }
                }
            }
        }
    }
    # ** -> download the package
    # if LWP::UA is present download the current package in the current dir
    elsif ( $_ eq '**' ) {
        unless ($ua) { print "WARNING: no LWP::UserAgent support!\n"; next; }
        if ( defined $$current{'+'}->[0] ) {
            ( my $gzfile =
                  'http://www.cpan.org/authors/id/' . $$current{'+'}->[1] ) =~
              s{.+/}{};
            my $resp =
              $ua->get( 'http://www.cpan.org/authors/id/' . $$current{'+'}->[1],
                ':content_file' => $gzfile );
            print $resp->is_success
              ? "OK: download of '$gzfile' succesfull\n"
              : "WARNING: ", $resp->status_line, "!\n";
        }
    }
    # ? -> shows infos and help
    # show the content of @infos array
    # id est: headers of the cpan file and usage of the program
    elsif ( $_ eq '?' ) { print for @infos }
    # unknown command
    else                { print "WARNING: '$_' command not found!\n"; next }
}
# in the continue block print the header of current namespace
continue { &header($current); }

sub header {
    my $hr = shift;
    my $num = scalar @{ [ grep $_ !~ $skiprx, keys %$hr ] };
    print "\n", ( join '::', @cur_names or 'CPAN' ),
      ( $$hr{'+'}->[0] ? "\t$$hr{'+'}->[0]\t$$hr{'+'}->[1]" : "" ),
      " contains ", $num, " namespace" . ( $num > 1 ? 's' : '' ) . "\n\n";
}
sub tree_dump
{
  my $ref  = shift;
  my $deep = shift || 1;
  foreach my $k (grep  $_ !~ $skiprx, sort keys %{$ref})     {
          print "\t" x $deep . "$k\n";
          if (ref( ${$ref}{$k}) eq 'HASH') {&tree_dump (${$ref}{$k}, ($deep+1))}
  }
}