File Coverage

lib/CPAN/Admin.pm

Criterion	Covered	Total	%
statement	15	116	12.9
branch	0	36	0.0
condition	0	10	0.0
subroutine	5	8	62.5
pod	0	2	0.0
total	20	172	11.6

package CPAN::Admin;
use base CPAN;
use CPAN; # old base.pm did not load CPAN on previous line
use strict;
use vars qw(@EXPORT $VERSION);
use constant PAUSE_IP => "pause.perl.org";

@EXPORT = qw(shell);
$VERSION = "5.5";
push @CPAN::Complete::COMMANDS, qw(register modsearch);
$CPAN::Shell::COLOR_REGISTERED = 1;

sub shell {
    CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
}

sub CPAN::Shell::register {
    my($self,$mod,@rest) = @_;
    unless ($mod) {
        print "register called without argument\n";
        return;
    }
    if ($CPAN::META->has_inst("URI::Escape")) {
        require URI::Escape;
    } else {
        print "register requires URI::Escape installed, otherwise it cannot work\n";
        return;
    }
    print "Got request for mod[$mod]\n";
    if (@rest) {
        my $modline = join " ", $mod, @rest;
        print "Sending to PAUSE [$modline]\n";
        my $emodline = URI::Escape::uri_escape($modline, '^\w ');
        $emodline =~ s/ /+/g;
        my $url =
            sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
                    "%s;SUBMIT_pause99_add_mod_hint=hint",
                    PAUSE_IP,
                    $emodline,
                   );
        print "url[$url]\n\n";
        print ">>>>Trying to open a netscape window<<<<\n";
        sleep 1;
        system("netscape","-remote","openURL($url)");
        return;
    }
    my $m = CPAN::Shell->expand("Module",$mod);
    unless (ref $m) {
        print "Could not determine the object for $mod\n";
        return;
    }
    my $id = $m->id;
    print "Found module id[$id] in database\n";

    if (exists $m->{RO} && $m->{RO}{chapterid}) {
        print "$id is already registered\n";
        return;
    }

    my(@namespace) = split /::/, $id;
    my $rootns = $namespace[0];

    # Tk, XML and Apache need special treatment
    if ($rootns=~/^(Bundle)\b/) {
        print "Bundles are not yet ready for registering\n";
        return;
    }

    # make a good suggestion for the chapter
    my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
    print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
    my(%seench);
    for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
        next unless $ch;
        $seench{$ch}=undef;
    }
    my(@seench) = sort grep {length($_)} keys %seench;
    my $reco_ch = "";
    if (@seench>1) {
        print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
        $reco_ch = $seench[0];
        print "Picking $reco_ch\n";
    } elsif (@seench==1) {
        print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
        $reco_ch = $seench[0];
    } else {
        print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
    }

    # Look closer at the dist
    my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
    printf "Module comes with dist[%s]\n", $d->id;
    for my $contm ($d->containsmods) {
        if ($CPAN::META->exists("CPAN::Module",$contm)) {
            my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
            my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
            printf(" in same dist: %s%s\n",
                   $contm,
                   $is_reg ? " already in modulelist" : "",
                  );
        }
    }

    # get it so that m is better and we can inspect for XS
    CPAN::Shell->get($id);
    CPAN::Shell->m($id);
    CPAN::Shell->d($d->id);

    my $has_xs = 0;
    {
        my($mani,@mani);
        local $/ = "\n";
        open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
        my @xs = grep /\.xs\b/, @mani;
        if (@xs) {
            print "Found XS files: @xs";
            $has_xs=1;
        }
    }
    my $emodid = URI::Escape::uri_escape($id, '\W');
    my $ech = $reco_ch;
    $ech =~ s/ /+/g;
    my $description = $m->{MANPAGE} || "";
    $description =~ s/[A-Z]
    $description =~ s/^\s+//; # leading spaces
    $description =~ s/>//; # POD
    $description =~ s/^\Q$id\E//; # usually this line starts with the modid
    $description =~ s/^[ \-]+//; # leading spaces and dashes
    substr($description,44) = "" if length($description)>44;
    $description = ucfirst($description);
    my $edescription = URI::Escape::uri_escape($description, '^\w ');
    $edescription =~ s/ /+/g;
    my $url =
        sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
                "%s;pause99_add_mod_chapterid=%s;pause99_add_mod_statd=%s;".
                "pause99_add_mod_stats=%s;pause99_add_mod_statl=%s;".
                "pause99_add_mod_stati=%s;pause99_add_mod_description=%s;".
                "pause99_add_mod_userid=%s;SUBMIT_pause99_add_mod_preview=preview",
                PAUSE_IP,
                $emodid,
                $ech,
                "R",
                "d",
                $has_xs ? "c" : "p",
                "O",
                $edescription,
                $m->{RO}{CPAN_USERID},
               );
    print "$url\n\n";
    print ">>>>Trying to open a netscape window<<<<\n";
    system("netscape","-remote","openURL($url)");
}

sub CPAN::Shell::modsearch {
    my($self,@line) = @_;
    unless (@line) {
        print "modsearch called without argument\n";
        return;
    }
    my $request = join " ", @line;
    print "Got request[$request]\n";
    my $erequest = URI::Escape::uri_escape($request, '^\w ');
    $erequest =~ s/ /+/g;
    my $url =
        sprintf("http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=%s".
                "&errors=0&case=on&maxfiles=100&maxlines=30",
                $erequest,
               );
    print "$url\n\n";
    print ">>>>Trying to open a netscape window<<<<\n";
    system("netscape","-remote","openURL('$url')");
}

1;

__END__