From: Nicholas Clark Date: Mon, 7 Nov 2005 10:52:08 +0000 (+0000) Subject: Add lib/CPAN/Admin.pm from CPAN to make version.t pass. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7d0beb42a2610634ab455d4519a64df3ca90bc2f;p=p5sagit%2Fp5-mst-13.2.git Add lib/CPAN/Admin.pm from CPAN to make version.t pass. p4raw-id: //depot/perl@26029 --- diff --git a/MANIFEST b/MANIFEST index 2a2c165..3da312c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1349,6 +1349,7 @@ lib/Config.t See if Config works lib/constant.pm For "use constant" lib/constant.t See if compile-time constants work lib/CPAN/bin/cpan easily interact with CPAN from the command line +lib/CPAN/Admin.pm A CPAN Shell for CPAN admins lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/CPAN/PAUSE2003.pub CPAN public key diff --git a/lib/CPAN/Admin.pm b/lib/CPAN/Admin.pm new file mode 100644 index 0000000..5c3068e --- /dev/null +++ b/lib/CPAN/Admin.pm @@ -0,0 +1,221 @@ +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 = sprintf "%.2f", substr(q$Rev: 231 $,4)/100; +push @CPAN::Complete::COMMANDS, qw(register modsearch); +if ($CPAN::META->has_inst("Term::ANSIColor")) { + $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]//; # 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__ + +=head1 NAME + +CPAN::Admin - A CPAN Shell for CPAN admins + +=head1 SYNOPSIS + +perl -MCPAN::Admin -e shell + +=head1 DESCRIPTION + +CPAN::Admin is a subclass of CPAN that adds the commands C +and C to the CPAN shell. + +C calls C on the named module, assembles a couple of +informations (description, language), and calls Netscape with the +-remote argument so that a form is filled with all the assembled +informations and the registration can be performed with a single +click. If the command line has more than one argument, register does +not run a C, instead it interprets the rest of the line as DSLI +status, description, and userid and sends them to netscape such that +the form is again mostly filled and can be edited or confirmed with a +single click. CPAN::Admin never performs the submission click for you, +it is only intended to fill in the form on PAUSE and leave the +confirmation to you. + +C simply passes the arguments to the search engine for the +modules@perl.org mailing list at http://www.xray.mpe.mpg.de where all +registration requests are stored. It does so in the same way as +register, namely with the C command. + +An experimental feature has also been added, namely to color already +registered modules in listings. If you have Term::ANSIColor installed, +the u, r, and m commands will show already registered modules in +green. + +=head1 PREREQISITES + +URI::Escape, netscape browser available in the path, netscape must +understand the -remote switch (as far as I know, this is only +available on UNIX); coloring of registered modules is only available +if Term::ANSIColor is installed. + +=cut