Commit | Line | Data |
3fea05b9 |
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 = "5.5"; |
10 | push @CPAN::Complete::COMMANDS, qw(register modsearch); |
11 | $CPAN::Shell::COLOR_REGISTERED = 1; |
12 | |
13 | sub shell { |
14 | CPAN::shell($_[0]||"admin's cpan> ",$_[1]); |
15 | } |
16 | |
17 | sub CPAN::Shell::register { |
18 | my($self,$mod,@rest) = @_; |
19 | unless ($mod) { |
20 | print "register called without argument\n"; |
21 | return; |
22 | } |
23 | if ($CPAN::META->has_inst("URI::Escape")) { |
24 | require URI::Escape; |
25 | } else { |
26 | print "register requires URI::Escape installed, otherwise it cannot work\n"; |
27 | return; |
28 | } |
29 | print "Got request for mod[$mod]\n"; |
30 | if (@rest) { |
31 | my $modline = join " ", $mod, @rest; |
32 | print "Sending to PAUSE [$modline]\n"; |
33 | my $emodline = URI::Escape::uri_escape($modline, '^\w '); |
34 | $emodline =~ s/ /+/g; |
35 | 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 | print "url[$url]\n\n"; |
42 | print ">>>>Trying to open a netscape window<<<<\n"; |
43 | sleep 1; |
44 | system("netscape","-remote","openURL($url)"); |
45 | return; |
46 | } |
47 | my $m = CPAN::Shell->expand("Module",$mod); |
48 | unless (ref $m) { |
49 | print "Could not determine the object for $mod\n"; |
50 | return; |
51 | } |
52 | my $id = $m->id; |
53 | print "Found module id[$id] in database\n"; |
54 | |
55 | if (exists $m->{RO} && $m->{RO}{chapterid}) { |
56 | print "$id is already registered\n"; |
57 | return; |
58 | } |
59 | |
60 | my(@namespace) = split /::/, $id; |
61 | my $rootns = $namespace[0]; |
62 | |
63 | # Tk, XML and Apache need special treatment |
64 | if ($rootns=~/^(Bundle)\b/) { |
65 | print "Bundles are not yet ready for registering\n"; |
66 | return; |
67 | } |
68 | |
69 | # make a good suggestion for the chapter |
70 | my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/"); |
71 | print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n"; |
72 | my(%seench); |
73 | for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) { |
74 | next unless $ch; |
75 | $seench{$ch}=undef; |
76 | } |
77 | my(@seench) = sort grep {length($_)} keys %seench; |
78 | my $reco_ch = ""; |
79 | if (@seench>1) { |
80 | print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n"; |
81 | $reco_ch = $seench[0]; |
82 | print "Picking $reco_ch\n"; |
83 | } elsif (@seench==1) { |
84 | print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n"; |
85 | $reco_ch = $seench[0]; |
86 | } else { |
87 | print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n"; |
88 | } |
89 | |
90 | # Look closer at the dist |
91 | my $d = CPAN::Shell->expand("Distribution", $m->cpan_file); |
92 | printf "Module comes with dist[%s]\n", $d->id; |
93 | for my $contm ($d->containsmods) { |
94 | if ($CPAN::META->exists("CPAN::Module",$contm)) { |
95 | my $contm_obj = CPAN::Shell->expand("Module",$contm) or next; |
96 | my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description}; |
97 | 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 | CPAN::Shell->get($id); |
106 | CPAN::Shell->m($id); |
107 | CPAN::Shell->d($d->id); |
108 | |
109 | my $has_xs = 0; |
110 | { |
111 | my($mani,@mani); |
112 | local $/ = "\n"; |
113 | open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>; |
114 | my @xs = grep /\.xs\b/, @mani; |
115 | if (@xs) { |
116 | print "Found XS files: @xs"; |
117 | $has_xs=1; |
118 | } |
119 | } |
120 | my $emodid = URI::Escape::uri_escape($id, '\W'); |
121 | my $ech = $reco_ch; |
122 | $ech =~ s/ /+/g; |
123 | my $description = $m->{MANPAGE} || ""; |
124 | $description =~ s/[A-Z]<//; # POD markup (and maybe more) |
125 | $description =~ s/^\s+//; # leading spaces |
126 | $description =~ s/>//; # POD |
127 | $description =~ s/^\Q$id\E//; # usually this line starts with the modid |
128 | $description =~ s/^[ \-]+//; # leading spaces and dashes |
129 | substr($description,44) = "" if length($description)>44; |
130 | $description = ucfirst($description); |
131 | my $edescription = URI::Escape::uri_escape($description, '^\w '); |
132 | $edescription =~ s/ /+/g; |
133 | 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 | print "$url\n\n"; |
150 | print ">>>>Trying to open a netscape window<<<<\n"; |
151 | system("netscape","-remote","openURL($url)"); |
152 | } |
153 | |
154 | sub CPAN::Shell::modsearch { |
155 | my($self,@line) = @_; |
156 | unless (@line) { |
157 | print "modsearch called without argument\n"; |
158 | return; |
159 | } |
160 | my $request = join " ", @line; |
161 | print "Got request[$request]\n"; |
162 | my $erequest = URI::Escape::uri_escape($request, '^\w '); |
163 | $erequest =~ s/ /+/g; |
164 | 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 | print "$url\n\n"; |
170 | print ">>>>Trying to open a netscape window<<<<\n"; |
171 | system("netscape","-remote","openURL('$url')"); |
172 | } |
173 | |
174 | 1; |
175 | |
176 | __END__ |
177 | |
178 | =head1 NAME |
179 | |
180 | CPAN::Admin - A CPAN Shell for CPAN admins |
181 | |
182 | =head1 SYNOPSIS |
183 | |
184 | perl -MCPAN::Admin -e shell |
185 | |
186 | =head1 STATUS |
187 | |
188 | Note: this module is currently not maintained. If you need it and fix |
189 | it for your needs, please submit patches. |
190 | |
191 | =head1 DESCRIPTION |
192 | |
193 | CPAN::Admin is a subclass of CPAN that adds the commands C<register> |
194 | and C<modsearch> to the CPAN shell. |
195 | |
196 | C<register> calls C<get> on the named module, assembles a couple of |
197 | informations (description, language), and calls Netscape with the |
198 | -remote argument so that a form is filled with all the assembled |
199 | informations and the registration can be performed with a single |
200 | click. If the command line has more than one argument, register does |
201 | not run a C<get>, instead it interprets the rest of the line as DSLI |
202 | status, description, and userid and sends them to netscape such that |
203 | the form is again mostly filled and can be edited or confirmed with a |
204 | single click. CPAN::Admin never performs the submission click for you, |
205 | it is only intended to fill in the form on PAUSE and leave the |
206 | confirmation to you. |
207 | |
208 | C<modsearch> simply passes the arguments to the search engine for the |
209 | modules@perl.org mailing list at http://www.xray.mpe.mpg.de where all |
210 | registration requests are stored. It does so in the same way as |
211 | register, namely with the C<netscape -remote> command. |
212 | |
213 | An experimental feature has also been added, namely to color already |
214 | registered modules in listings. If you have Term::ANSIColor installed, |
215 | the u, r, and m commands will show already registered modules in |
216 | green. |
217 | |
218 | =head1 PREREQISITES |
219 | |
220 | URI::Escape, netscape browser available in the path, netscape must |
221 | understand the -remote switch (as far as I know, this is only |
222 | available on UNIX); coloring of registered modules is only available |
223 | if Term::ANSIColor is installed. |
224 | |
225 | =head1 LICENSE |
226 | |
227 | This program is free software; you can redistribute it and/or |
228 | modify it under the same terms as Perl itself. |
229 | |
230 | =cut |