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


line stmt bran cond sub pod time code
1             package CPAN::Admin;
2 1     1   2722 use base CPAN;
  1         3  
  1         99  
3 1     1   4 use CPAN; # old base.pm did not load CPAN on previous line
  1         3  
  1         149  
4 1     1   5 use strict;
  1         2  
  1         35  
5 1     1   4 use vars qw(@EXPORT $VERSION);
  1         1  
  1         48  
6 1     1   6 use constant PAUSE_IP => "pause.perl.org";
  1         1  
  1         1309  
7              
8             @EXPORT = qw(shell);
9             $VERSION = "5.5";
10             push @CPAN::Complete::COMMANDS, qw(register modsearch);
11             $CPAN::Shell::COLOR_REGISTERED = 1;
12              
13             sub shell {
14 0   0 0     CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
15             }
16              
17             sub CPAN::Shell::register {
18 0     0 0   my($self,$mod,@rest) = @_;
19 0 0         unless ($mod) {
20 0           print "register called without argument\n";
21 0           return;
22             }
23 0 0         if ($CPAN::META->has_inst("URI::Escape")) {
24 0           require URI::Escape;
25             } else {
26 0           print "register requires URI::Escape installed, otherwise it cannot work\n";
27 0           return;
28             }
29 0           print "Got request for mod[$mod]\n";
30 0 0         if (@rest) {
31 0           my $modline = join " ", $mod, @rest;
32 0           print "Sending to PAUSE [$modline]\n";
33 0           my $emodline = URI::Escape::uri_escape($modline, '^\w ');
34 0           $emodline =~ s/ /+/g;
35 0           my $url =
36             sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
37             "%s;SUBMIT_pause99_add_mod_hint=hint",
38             PAUSE_IP,
39             $emodline,
40             );
41 0           print "url[$url]\n\n";
42 0           print ">>>>Trying to open a netscape window<<<<\n";
43 0           sleep 1;
44 0           system("netscape","-remote","openURL($url)");
45 0           return;
46             }
47 0           my $m = CPAN::Shell->expand("Module",$mod);
48 0 0         unless (ref $m) {
49 0           print "Could not determine the object for $mod\n";
50 0           return;
51             }
52 0           my $id = $m->id;
53 0           print "Found module id[$id] in database\n";
54              
55 0 0 0       if (exists $m->{RO} && $m->{RO}{chapterid}) {
56 0           print "$id is already registered\n";
57 0           return;
58             }
59              
60 0           my(@namespace) = split /::/, $id;
61 0           my $rootns = $namespace[0];
62              
63             # Tk, XML and Apache need special treatment
64 0 0         if ($rootns=~/^(Bundle)\b/) {
65 0           print "Bundles are not yet ready for registering\n";
66 0           return;
67             }
68              
69             # make a good suggestion for the chapter
70 0           my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
71 0           print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
  0            
72 0           my(%seench);
73 0 0         for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
  0            
74 0 0         next unless $ch;
75 0           $seench{$ch}=undef;
76             }
77 0           my(@seench) = sort grep {length($_)} keys %seench;
  0            
78 0           my $reco_ch = "";
79 0 0         if (@seench>1) {
    0          
80 0           print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
81 0           $reco_ch = $seench[0];
82 0           print "Picking $reco_ch\n";
83             } elsif (@seench==1) {
84 0           print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
85 0           $reco_ch = $seench[0];
86             } else {
87 0           print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
88             }
89              
90             # Look closer at the dist
91 0           my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
92 0           printf "Module comes with dist[%s]\n", $d->id;
93 0           for my $contm ($d->containsmods) {
94 0 0         if ($CPAN::META->exists("CPAN::Module",$contm)) {
95 0 0         my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
96 0   0       my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
97 0 0         printf(" in same dist: %s%s\n",
98             $contm,
99             $is_reg ? " already in modulelist" : "",
100             );
101             }
102             }
103              
104             # get it so that m is better and we can inspect for XS
105 0           CPAN::Shell->get($id);
106 0           CPAN::Shell->m($id);
107 0           CPAN::Shell->d($d->id);
108              
109 0           my $has_xs = 0;
110             {
111 0           my($mani,@mani);
  0            
112 0           local $/ = "\n";
113 0 0         open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
114 0           my @xs = grep /\.xs\b/, @mani;
115 0 0         if (@xs) {
116 0           print "Found XS files: @xs";
117 0           $has_xs=1;
118             }
119             }
120 0           my $emodid = URI::Escape::uri_escape($id, '\W');
121 0           my $ech = $reco_ch;
122 0           $ech =~ s/ /+/g;
123 0   0       my $description = $m->{MANPAGE} || "";
124 0           $description =~ s/[A-Z]
125 0           $description =~ s/^\s+//; # leading spaces
126 0           $description =~ s/>//; # POD
127 0           $description =~ s/^\Q$id\E//; # usually this line starts with the modid
128 0           $description =~ s/^[ \-]+//; # leading spaces and dashes
129 0 0         substr($description,44) = "" if length($description)>44;
130 0           $description = ucfirst($description);
131 0           my $edescription = URI::Escape::uri_escape($description, '^\w ');
132 0           $edescription =~ s/ /+/g;
133 0 0         my $url =
134             sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
135             "%s;pause99_add_mod_chapterid=%s;pause99_add_mod_statd=%s;".
136             "pause99_add_mod_stats=%s;pause99_add_mod_statl=%s;".
137             "pause99_add_mod_stati=%s;pause99_add_mod_description=%s;".
138             "pause99_add_mod_userid=%s;SUBMIT_pause99_add_mod_preview=preview",
139             PAUSE_IP,
140             $emodid,
141             $ech,
142             "R",
143             "d",
144             $has_xs ? "c" : "p",
145             "O",
146             $edescription,
147             $m->{RO}{CPAN_USERID},
148             );
149 0           print "$url\n\n";
150 0           print ">>>>Trying to open a netscape window<<<<\n";
151 0           system("netscape","-remote","openURL($url)");
152             }
153              
154             sub CPAN::Shell::modsearch {
155 0     0 0   my($self,@line) = @_;
156 0 0         unless (@line) {
157 0           print "modsearch called without argument\n";
158 0           return;
159             }
160 0           my $request = join " ", @line;
161 0           print "Got request[$request]\n";
162 0           my $erequest = URI::Escape::uri_escape($request, '^\w ');
163 0           $erequest =~ s/ /+/g;
164 0           my $url =
165             sprintf("http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=%s".
166             "&errors=0&case=on&maxfiles=100&maxlines=30",
167             $erequest,
168             );
169 0           print "$url\n\n";
170 0           print ">>>>Trying to open a netscape window<<<<\n";
171 0           system("netscape","-remote","openURL('$url')");
172             }
173              
174             1;
175              
176             __END__