File Coverage

blib/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 1 1 100.0
total 21 171 12.3


line stmt bran cond sub pod time code
1             package CPAN::Admin;
2 1     1   19 use base CPAN;
  1         14  
  1         126  
3 1     1   18 use CPAN; # old base.pm did not load CPAN on previous line
  1         9  
  1         60  
4 1     1   17 use strict;
  1         9  
  1         16  
5 1     1   16 use vars qw(@EXPORT $VERSION);
  1         9  
  1         15  
6 1     1   43 use constant PAUSE_IP => "pause.perl.org";
  1         9  
  1         109  
7              
8             @EXPORT = qw(shell);
9             $VERSION = sprintf "%.6f", substr(q$Rev: 844 $,4)/1000000 + 5.4;
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 0   0 0 1     CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
16             }
17              
18             sub CPAN::Shell::register {
19 0     0       my($self,$mod,@rest) = @_;
20 0 0           unless ($mod){
21 0               print "register called without argument\n";
22 0               return;
23               }
24 0 0           if ($CPAN::META->has_inst("URI::Escape")) {
25 0               require URI::Escape;
26               } else {
27 0               print "register requires URI::Escape installed, otherwise it cannot work\n";
28 0               return;
29               }
30 0             print "Got request for mod[$mod]\n";
31 0 0           if (@rest) {
32 0               my $modline = join " ", $mod, @rest;
33 0               print "Sending to PAUSE [$modline]\n";
34 0               my $emodline = URI::Escape::uri_escape($modline, '^\w ');
35 0               $emodline =~ s/ /+/g;
36 0               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 0               print "url[$url]\n\n";
43 0               print ">>>>Trying to open a netscape window<<<<\n";
44 0               sleep 1;
45 0               system("netscape","-remote","openURL($url)");
46 0               return;
47               }
48 0             my $m = CPAN::Shell->expand("Module",$mod);
49 0 0           unless (ref $m) {
50 0               print "Could not determine the object for $mod\n";
51 0               return;
52               }
53 0             my $id = $m->id;
54 0             print "Found module id[$id] in database\n";
55              
56 0 0 0         if (exists $m->{RO} && $m->{RO}{chapterid}) {
57 0               print "$id is already registered\n";
58 0               return;
59               }
60              
61 0             my(@namespace) = split /::/, $id;
62 0             my $rootns = $namespace[0];
63              
64             # Tk, XML and Apache need special treatment
65 0 0           if ($rootns=~/^(Bundle)\b/){
66 0               print "Bundles are not yet ready for registering\n";
67 0               return;
68               }
69              
70             # make a good suggestion for the chapter
71 0             my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
72 0             print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
  0            
73 0             my(%seench);
74 0 0           for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
  0            
75 0 0             next unless $ch;
76 0               $seench{$ch}=undef;
77               }
78 0             my(@seench) = sort grep {length($_)} keys %seench;
  0            
79 0             my $reco_ch = "";
80 0 0           if (@seench>1) {
    0          
81 0               print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
82 0               $reco_ch = $seench[0];
83 0               print "Picking $reco_ch\n";
84               } elsif (@seench==1) {
85 0               print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
86 0               $reco_ch = $seench[0];
87               } else {
88 0               print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
89               }
90              
91             # Look closer at the dist
92 0             my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
93 0             printf "Module comes with dist[%s]\n", $d->id;
94 0             for my $contm ($d->containsmods) {
95 0 0             if ($CPAN::META->exists("CPAN::Module",$contm)) {
96 0 0               my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
97 0   0             my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
98 0 0               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 0             CPAN::Shell->get($id);
107 0             CPAN::Shell->m($id);
108 0             CPAN::Shell->d($d->id);
109              
110 0             my $has_xs = 0;
111               {
112 0               my($mani,@mani);
  0            
113 0               local $/ = "\n";
114 0 0             open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
115 0               my @xs = grep /\.xs\b/, @mani;
116 0 0             if (@xs) {
117 0                 print "Found XS files: @xs";
118 0                 $has_xs=1;
119                 }
120               }
121 0             my $emodid = URI::Escape::uri_escape($id, '\W');
122 0             my $ech = $reco_ch;
123 0             $ech =~ s/ /+/g;
124 0   0         my $description = $m->{MANPAGE} || "";
125 0             $description =~ s/[A-Z]<//; # POD markup (and maybe more)
126 0             $description =~ s/^\s+//; # leading spaces
127 0             $description =~ s/>//; # POD
128 0             $description =~ s/^\Q$id\E//; # usually this line starts with the modid
129 0             $description =~ s/^[ \-]+//; # leading spaces and dashes
130 0 0           substr($description,44) = "" if length($description)>44;
131 0             $description = ucfirst($description);
132 0             my $edescription = URI::Escape::uri_escape($description, '^\w ');
133 0             $edescription =~ s/ /+/g;
134 0 0           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 0             print "$url\n\n";
151 0             print ">>>>Trying to open a netscape window<<<<\n";
152 0             system("netscape","-remote","openURL($url)");
153             }
154              
155             sub CPAN::Shell::modsearch {
156 0     0       my($self,@line) = @_;
157 0 0           unless (@line){
158 0               print "modsearch called without argument\n";
159 0               return;
160               }
161 0             my $request = join " ", @line;
162 0             print "Got request[$request]\n";
163 0             my $erequest = URI::Escape::uri_escape($request, '^\w ');
164 0             $erequest =~ s/ /+/g;
165 0             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 0             print "$url\n\n";
171 0             print ">>>>Trying to open a netscape window<<<<\n";
172 0             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             =head1 LICENSE
222            
223             This program is free software; you can redistribute it and/or
224             modify it under the same terms as Perl itself.
225            
226             =cut
227