This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add lib/CPAN/Admin.pm from CPAN to make version.t pass.
[perl5.git] / lib / CPAN / Admin.pm
1 package CPAN::Admin;
2 use base CPAN;
3 use CPAN; # old base.pm did not load CPAN on previous line
4 use strict;
5 use vars qw(@EXPORT $VERSION);
6 use constant PAUSE_IP => "pause.perl.org";
7
8 @EXPORT = qw(shell);
9 $VERSION = sprintf "%.2f", substr(q$Rev: 231 $,4)/100;
10 push @CPAN::Complete::COMMANDS, qw(register modsearch);
11 if ($CPAN::META->has_inst("Term::ANSIColor")) {
12   $CPAN::Shell::COLOR_REGISTERED = 1;
13 }
14 sub shell {
15   CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
16 }
17
18 sub CPAN::Shell::register {
19   my($self,$mod,@rest) = @_;
20   unless ($mod){
21     print "register called without argument\n";
22     return;
23   }
24   if ($CPAN::META->has_inst("URI::Escape")) {
25     require URI::Escape;
26   } else {
27     print "register requires URI::Escape installed, otherwise it cannot work\n";
28     return;
29   }
30   print "Got request for mod[$mod]\n";
31   if (@rest) {
32     my $modline = join " ", $mod, @rest;
33     print "Sending to PAUSE [$modline]\n";
34     my $emodline = URI::Escape::uri_escape($modline, '^\w ');
35     $emodline =~ s/ /+/g;
36     my $url =
37         sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
38                 "%s;SUBMIT_pause99_add_mod_hint=hint",
39                 PAUSE_IP,
40                 $emodline,
41                );
42     print "url[$url]\n\n";
43     print ">>>>Trying to open a netscape window<<<<\n";
44     sleep 1;
45     system("netscape","-remote","openURL($url)");
46     return;
47   }
48   my $m = CPAN::Shell->expand("Module",$mod);
49   unless (ref $m) {
50     print "Could not determine the object for $mod\n";
51     return;
52   }
53   my $id = $m->id;
54   print "Found module id[$id] in database\n";
55
56   if (exists $m->{RO} && $m->{RO}{chapterid}) {
57     print "$id is already registered\n";
58     return;
59   }
60
61   my(@namespace) = split /::/, $id;
62   my $rootns = $namespace[0];
63
64   # Tk, XML and Apache need special treatment
65   if ($rootns=~/^(Bundle)\b/){
66     print "Bundles are not yet ready for registering\n";
67     return;
68   }
69
70   # make a good suggestion for the chapter
71   my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
72   print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
73   my(%seench);
74   for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
75     next unless $ch;
76     $seench{$ch}=undef;
77   }
78   my(@seench) = sort grep {length($_)} keys %seench;
79   my $reco_ch = "";
80   if (@seench>1) {
81     print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
82     $reco_ch = $seench[0];
83     print "Picking $reco_ch\n";
84   } elsif (@seench==1) {
85     print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
86     $reco_ch = $seench[0];
87   } else {
88     print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
89   }
90
91   # Look closer at the dist
92   my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
93   printf "Module comes with dist[%s]\n", $d->id;
94   for my $contm ($d->containsmods) {
95     if ($CPAN::META->exists("CPAN::Module",$contm)) {
96       my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
97       my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
98       printf(" in same dist: %s%s\n",
99              $contm,
100              $is_reg ? " already in modulelist" : "",
101             );
102     }
103   }
104
105   # get it so that m is better and we can inspect for XS
106   CPAN::Shell->get($id);
107   CPAN::Shell->m($id);
108   CPAN::Shell->d($d->id);
109
110   my $has_xs = 0;
111   {
112     my($mani,@mani);
113     local $/ = "\n";
114     open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
115     my @xs = grep /\.xs\b/, @mani;
116     if (@xs) {
117       print "Found XS files: @xs";
118       $has_xs=1;
119     }
120   }
121   my $emodid = URI::Escape::uri_escape($id, '\W');
122   my $ech = $reco_ch;
123   $ech =~ s/ /+/g;
124   my $description = $m->{MANPAGE} || "";
125   $description =~ s/[A-Z]<//; # POD markup (and maybe more)
126   $description =~ s/^\s+//; # leading spaces
127   $description =~ s/>//; # POD
128   $description =~ s/^\Q$id\E//; # usually this line starts with the modid
129   $description =~ s/^[ \-]+//; # leading spaces and dashes
130   substr($description,44) = "" if length($description)>44;
131   $description = ucfirst($description);
132   my $edescription = URI::Escape::uri_escape($description, '^\w ');
133   $edescription =~ s/ /+/g;
134   my $url =
135       sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
136               "%s;pause99_add_mod_chapterid=%s;pause99_add_mod_statd=%s;".
137               "pause99_add_mod_stats=%s;pause99_add_mod_statl=%s;".
138               "pause99_add_mod_stati=%s;pause99_add_mod_description=%s;".
139               "pause99_add_mod_userid=%s;SUBMIT_pause99_add_mod_preview=preview",
140               PAUSE_IP,
141               $emodid,
142               $ech,
143               "R",
144               "d",
145               $has_xs ? "c" : "p",
146               "O",
147               $edescription,
148               $m->{RO}{CPAN_USERID},
149              );
150   print "$url\n\n";
151   print ">>>>Trying to open a netscape window<<<<\n";
152   system("netscape","-remote","openURL($url)");
153 }
154
155 sub CPAN::Shell::modsearch {
156   my($self,@line) = @_;
157   unless (@line){
158     print "modsearch called without argument\n";
159     return;
160   }
161   my $request = join " ", @line;
162   print "Got request[$request]\n";
163   my $erequest = URI::Escape::uri_escape($request, '^\w ');
164   $erequest =~ s/ /+/g;
165   my $url =
166       sprintf("http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=%s".
167               "&errors=0&case=on&maxfiles=100&maxlines=30",
168               $erequest,
169              );
170   print "$url\n\n";
171   print ">>>>Trying to open a netscape window<<<<\n";
172   system("netscape","-remote","openURL('$url')");
173 }
174
175 1;
176
177 __END__
178
179 =head1 NAME
180
181 CPAN::Admin - A CPAN Shell for CPAN admins
182
183 =head1 SYNOPSIS
184
185 perl -MCPAN::Admin -e shell
186
187 =head1 DESCRIPTION
188
189 CPAN::Admin is a subclass of CPAN that adds the commands C<register>
190 and C<modsearch> to the CPAN shell.
191
192 C<register> calls C<get> on the named module, assembles a couple of
193 informations (description, language), and calls Netscape with the
194 -remote argument so that a form is filled with all the assembled
195 informations and the registration can be performed with a single
196 click. If the command line has more than one argument, register does
197 not run a C<get>, instead it interprets the rest of the line as DSLI
198 status, description, and userid and sends them to netscape such that
199 the form is again mostly filled and can be edited or confirmed with a
200 single click. CPAN::Admin never performs the submission click for you,
201 it is only intended to fill in the form on PAUSE and leave the
202 confirmation to you.
203
204 C<modsearch> simply passes the arguments to the search engine for the
205 modules@perl.org mailing list at http://www.xray.mpe.mpg.de where all
206 registration requests are stored. It does so in the same way as
207 register, namely with the C<netscape -remote> command.
208
209 An experimental feature has also been added, namely to color already
210 registered modules in listings. If you have Term::ANSIColor installed,
211 the u, r, and m commands will show already registered modules in
212 green.
213
214 =head1 PREREQISITES
215
216 URI::Escape, netscape browser available in the path, netscape must
217 understand the -remote switch (as far as I know, this is only
218 available on UNIX); coloring of registered modules is only available
219 if Term::ANSIColor is installed.
220
221 =cut