use vars qw(@EXPORT $VERSION);use constant PAUSE_IP => "pause.perl.org";@EXPORT = qw(shell);
$VERSION = "5.501";
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")) {
} 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 =
"%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];
if ($rootns=~/^(Bundle)\b/) {
print "Bundles are not yet ready for registering\n";
return;
}
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";
}
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" : "",
);
}
}
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+//;
$description =~ s/>//;
$description =~ s/^\Q$id\E//;
$description =~ s/^[ \-]+//;
substr($description,44) = "" if length($description)>44;
$description = ucfirst($description);
my $edescription = URI::Escape::uri_escape($description, '^\w ');
$edescription =~ s/ /+/g;
my $url =
"%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 =
"&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;