Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Backend; |
2 | |
3 | use strict; |
4 | |
5 | |
6 | use CPANPLUS::Error; |
7 | use CPANPLUS::Configure; |
8 | use CPANPLUS::Internals; |
9 | use CPANPLUS::Internals::Constants; |
10 | use CPANPLUS::Module; |
11 | use CPANPLUS::Module::Author; |
12 | use CPANPLUS::Backend::RV; |
13 | |
14 | use FileHandle; |
15 | use File::Spec (); |
16 | use File::Spec::Unix (); |
a0995fd4 |
17 | use File::Basename (); |
6aaee015 |
18 | use Params::Check qw[check]; |
19 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
20 | |
21 | $Params::Check::VERBOSE = 1; |
22 | |
23 | use vars qw[@ISA $VERSION]; |
24 | |
25 | @ISA = qw[CPANPLUS::Internals]; |
26 | $VERSION = $CPANPLUS::Internals::VERSION; |
27 | |
28 | ### mark that we're running under CPANPLUS to spawned processes |
29 | $ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$; |
30 | |
31 | ### XXX version.pm MAY format this version, if it's in use... :( |
32 | ### so for consistency, just call ->VERSION ourselves as well. |
33 | $ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION; |
34 | |
35 | =pod |
36 | |
37 | =head1 NAME |
38 | |
39 | CPANPLUS::Backend |
40 | |
41 | =head1 SYNOPSIS |
42 | |
5bc5f6dc |
43 | my $cb = CPANPLUS::Backend->new; |
6aaee015 |
44 | my $conf = $cb->configure_object; |
45 | |
46 | my $author = $cb->author_tree('KANE'); |
47 | my $mod = $cb->module_tree('Some::Module'); |
48 | my $mod = $cb->parse_module( module => 'Some::Module' ); |
49 | |
50 | my @objs = $cb->search( type => TYPE, |
51 | allow => [...] ); |
52 | |
53 | $cb->flush('all'); |
54 | $cb->reload_indices; |
55 | $cb->local_mirror; |
56 | |
57 | |
58 | =head1 DESCRIPTION |
59 | |
60 | This module provides the programmer's interface to the C<CPANPLUS> |
61 | libraries. |
62 | |
63 | =head1 ENVIRONMENT |
64 | |
65 | When C<CPANPLUS::Backend> is loaded, which is necessary for just |
66 | about every <CPANPLUS> operation, the environment variable |
67 | C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id. |
68 | |
69 | Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> |
70 | will be set to the version of C<CPANPLUS::Backend>. |
71 | |
72 | This information might be useful somehow to spawned processes. |
73 | |
74 | =head1 METHODS |
75 | |
76 | =head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) |
77 | |
78 | This method returns a new C<CPANPLUS::Backend> object. |
79 | This also initialises the config corresponding to this object. |
80 | You have two choices in this: |
81 | |
82 | =over 4 |
83 | |
84 | =item Provide a valid C<CPANPLUS::Configure> object |
85 | |
86 | This will be used verbatim. |
87 | |
88 | =item No arguments |
89 | |
90 | Your default config will be loaded and used. |
91 | |
92 | =back |
93 | |
94 | New will return a C<CPANPLUS::Backend> object on success and die on |
95 | failure. |
96 | |
97 | =cut |
98 | |
99 | sub new { |
100 | my $class = shift; |
101 | my $conf; |
102 | |
103 | if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) { |
104 | $conf = shift; |
105 | } else { |
106 | $conf = CPANPLUS::Configure->new() or return; |
107 | } |
108 | |
109 | my $self = $class->SUPER::_init( _conf => $conf ); |
110 | |
111 | return $self; |
112 | } |
113 | |
114 | =pod |
115 | |
116 | =head2 $href = $cb->module_tree( [@modules_names_list] ) |
117 | |
118 | Returns a reference to the CPANPLUS module tree. |
119 | |
120 | If you give it any arguments, they will be treated as module names |
121 | and C<module_tree> will try to look up these module names and |
122 | return the corresponding module objects instead. |
123 | |
124 | See L<CPANPLUS::Module> for the operations you can perform on a |
125 | module object. |
126 | |
127 | =cut |
128 | |
129 | sub module_tree { |
130 | my $self = shift; |
131 | my $modtree = $self->_module_tree; |
132 | |
133 | if( @_ ) { |
134 | my @rv; |
135 | for my $name ( grep { defined } @_) { |
5879cbe1 |
136 | |
137 | ### From John Malmberg: This is failing on VMS |
138 | ### because ODS-2 does not retain the case of |
139 | ### filenames that are created. |
140 | ### The problem is the filename is being converted |
141 | ### to a module name and then looked up in the |
142 | ### %$modtree hash. |
143 | ### |
144 | ### As a fix, we do a search on VMS instead -- |
145 | ### more cpu cycles, but it gets around the case |
146 | ### problem --kane |
147 | my ($modobj) = do { |
148 | ON_VMS |
149 | ? $self->search( |
150 | type => 'module', |
151 | allow => [qr/^$name$/i], |
152 | ) |
153 | : $modtree->{$name} |
154 | }; |
155 | |
156 | push @rv, $modobj || ''; |
6aaee015 |
157 | } |
158 | return @rv == 1 ? $rv[0] : @rv; |
159 | } else { |
160 | return $modtree; |
161 | } |
162 | } |
163 | |
164 | =pod |
165 | |
166 | =head2 $href = $cb->author_tree( [@author_names_list] ) |
167 | |
168 | Returns a reference to the CPANPLUS author tree. |
169 | |
170 | If you give it any arguments, they will be treated as author names |
171 | and C<author_tree> will try to look up these author names and |
172 | return the corresponding author objects instead. |
173 | |
174 | See L<CPANPLUS::Module::Author> for the operations you can perform on |
175 | an author object. |
176 | |
177 | =cut |
178 | |
179 | sub author_tree { |
180 | my $self = shift; |
181 | my $authtree = $self->_author_tree; |
182 | |
183 | if( @_ ) { |
184 | my @rv; |
185 | for my $name (@_) { |
186 | push @rv, $authtree->{$name} || ''; |
187 | } |
188 | return @rv == 1 ? $rv[0] : @rv; |
189 | } else { |
190 | return $authtree; |
191 | } |
192 | } |
193 | |
194 | =pod |
195 | |
5bc5f6dc |
196 | =head2 $conf = $cb->configure_object; |
6aaee015 |
197 | |
198 | Returns a copy of the C<CPANPLUS::Configure> object. |
199 | |
200 | See L<CPANPLUS::Configure> for operations you can perform on a |
201 | configure object. |
202 | |
203 | =cut |
204 | |
205 | sub configure_object { return shift->_conf() }; |
206 | |
207 | =head2 $su = $cb->selfupdate_object; |
208 | |
209 | Returns a copy of the C<CPANPLUS::Selfupdate> object. |
210 | |
211 | See the L<CPANPLUS::Selfupdate> manpage for the operations |
212 | you can perform on the selfupdate object. |
213 | |
214 | =cut |
215 | |
216 | sub selfupdate_object { return shift->_selfupdate() }; |
217 | |
218 | =pod |
219 | |
220 | =head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] ) |
221 | |
222 | C<search> enables you to search for either module or author objects, |
223 | based on their data. The C<type> you can specify is any of the |
224 | accessors specified in C<CPANPLUS::Module::Author> or |
225 | C<CPANPLUS::Module>. C<search> will determine by the C<type> you |
226 | specified whether to search by author object or module object. |
227 | |
228 | You have to specify an array reference of regular expressions or |
229 | strings to match against. The rules used for this array ref are the |
230 | same as in C<Params::Check>, so read that manpage for details. |
231 | |
232 | The search is an C<or> search, meaning that if C<any> of the criteria |
233 | match, the search is considered to be successful. |
234 | |
235 | You can specify the result of a previous search as C<data> to limit |
236 | the new search to these module or author objects, rather than the |
237 | entire module or author tree. This is how you do C<and> searches. |
238 | |
239 | Returns a list of module or author objects on success and false |
240 | on failure. |
241 | |
242 | See L<CPANPLUS::Module> for the operations you can perform on a |
243 | module object. |
244 | See L<CPANPLUS::Module::Author> for the operations you can perform on |
245 | an author object. |
246 | |
247 | =cut |
248 | |
249 | sub search { |
250 | my $self = shift; |
251 | my $conf = $self->configure_object; |
252 | my %hash = @_; |
253 | |
5879cbe1 |
254 | my ($type); |
255 | my $args = do { |
256 | local $Params::Check::NO_DUPLICATES = 0; |
257 | local $Params::Check::ALLOW_UNKNOWN = 1; |
6aaee015 |
258 | |
5879cbe1 |
259 | my $tmpl = { |
260 | type => { required => 1, allow => [CPANPLUS::Module->accessors(), |
261 | CPANPLUS::Module::Author->accessors()], store => \$type }, |
262 | allow => { required => 1, default => [ ], strict_type => 1 }, |
263 | }; |
6aaee015 |
264 | |
5879cbe1 |
265 | check( $tmpl, \%hash ) |
266 | } or return; |
6aaee015 |
267 | |
268 | ### figure out whether it was an author or a module search |
269 | ### when ambiguous, it'll be an author search. |
270 | my $aref; |
271 | if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) { |
272 | $aref = $self->_search_author_tree( %$args ); |
273 | } else { |
274 | $aref = $self->_search_module_tree( %$args ); |
275 | } |
276 | |
277 | return @$aref if $aref; |
278 | return; |
279 | } |
280 | |
281 | =pod |
282 | |
283 | =head2 $backend_rv = $cb->fetch( modules => \@mods ) |
284 | |
285 | Fetches a list of modules. C<@mods> can be a list of distribution |
286 | names, module names or module objects--basically anything that |
287 | L<parse_module> can understand. |
288 | |
289 | See the equivalent method in C<CPANPLUS::Module> for details on |
290 | other options you can pass. |
291 | |
292 | Since this is a multi-module method call, the return value is |
293 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
294 | that module's documentation on how to interpret the return value. |
295 | |
296 | =head2 $backend_rv = $cb->extract( modules => \@mods ) |
297 | |
298 | Extracts a list of modules. C<@mods> can be a list of distribution |
299 | names, module names or module objects--basically anything that |
300 | L<parse_module> can understand. |
301 | |
302 | See the equivalent method in C<CPANPLUS::Module> for details on |
303 | other options you can pass. |
304 | |
305 | Since this is a multi-module method call, the return value is |
306 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
307 | that module's documentation on how to interpret the return value. |
308 | |
309 | =head2 $backend_rv = $cb->install( modules => \@mods ) |
310 | |
311 | Installs a list of modules. C<@mods> can be a list of distribution |
312 | names, module names or module objects--basically anything that |
313 | L<parse_module> can understand. |
314 | |
315 | See the equivalent method in C<CPANPLUS::Module> for details on |
316 | other options you can pass. |
317 | |
318 | Since this is a multi-module method call, the return value is |
319 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
320 | that module's documentation on how to interpret the return value. |
321 | |
322 | =head2 $backend_rv = $cb->readme( modules => \@mods ) |
323 | |
324 | Fetches the readme for a list of modules. C<@mods> can be a list of |
325 | distribution names, module names or module objects--basically |
326 | anything that L<parse_module> can understand. |
327 | |
328 | See the equivalent method in C<CPANPLUS::Module> for details on |
329 | other options you can pass. |
330 | |
331 | Since this is a multi-module method call, the return value is |
332 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
333 | that module's documentation on how to interpret the return value. |
334 | |
335 | =head2 $backend_rv = $cb->files( modules => \@mods ) |
336 | |
337 | Returns a list of files used by these modules if they are installed. |
338 | C<@mods> can be a list of distribution names, module names or module |
339 | objects--basically anything that L<parse_module> can understand. |
340 | |
341 | See the equivalent method in C<CPANPLUS::Module> for details on |
342 | other options you can pass. |
343 | |
344 | Since this is a multi-module method call, the return value is |
345 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
346 | that module's documentation on how to interpret the return value. |
347 | |
348 | =head2 $backend_rv = $cb->distributions( modules => \@mods ) |
349 | |
350 | Returns a list of module objects representing all releases for this |
351 | module on success. |
352 | C<@mods> can be a list of distribution names, module names or module |
353 | objects, basically anything that L<parse_module> can understand. |
354 | |
355 | See the equivalent method in C<CPANPLUS::Module> for details on |
356 | other options you can pass. |
357 | |
358 | Since this is a multi-module method call, the return value is |
359 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
360 | that module's documentation on how to interpret the return value. |
361 | |
362 | =cut |
363 | |
364 | ### XXX add direcotry_tree, packlist etc? or maybe remove files? ### |
365 | for my $func (qw[fetch extract install readme files distributions]) { |
366 | no strict 'refs'; |
367 | |
368 | *$func = sub { |
369 | my $self = shift; |
370 | my $conf = $self->configure_object; |
371 | my %hash = @_; |
372 | |
6aaee015 |
373 | my ($mods); |
4443dd53 |
374 | my $args = do { |
375 | local $Params::Check::NO_DUPLICATES = 1; |
376 | local $Params::Check::ALLOW_UNKNOWN = 1; |
377 | |
378 | my $tmpl = { |
379 | modules => { default => [], strict_type => 1, |
380 | required => 1, store => \$mods }, |
381 | }; |
6aaee015 |
382 | |
4443dd53 |
383 | check( $tmpl, \%hash ); |
384 | } or return; |
6aaee015 |
385 | |
386 | ### make them all into module objects ### |
4443dd53 |
387 | my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods; |
6aaee015 |
388 | |
389 | my $flag; my $href; |
390 | while( my($name,$obj) = each %mods ) { |
391 | $href->{$name} = IS_MODOBJ->( mod => $obj ) |
392 | ? $obj->$func( %$args ) |
393 | : undef; |
394 | |
395 | $flag++ unless $href->{$name}; |
396 | } |
397 | |
398 | return CPANPLUS::Backend::RV->new( |
399 | function => $func, |
400 | ok => !$flag, |
401 | rv => $href, |
402 | args => \%hash, |
403 | ); |
404 | } |
405 | } |
406 | |
407 | =pod |
408 | |
a0995fd4 |
409 | =head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH ) |
6aaee015 |
410 | |
411 | C<parse_module> tries to find a C<CPANPLUS::Module> object that |
412 | matches your query. Here's a list of examples you could give to |
413 | C<parse_module>; |
414 | |
415 | =over 4 |
416 | |
417 | =item Text::Bastardize |
418 | |
419 | =item Text-Bastardize |
420 | |
421 | =item Text-Bastardize-1.06 |
422 | |
423 | =item AYRNIEU/Text-Bastardize |
424 | |
425 | =item AYRNIEU/Text-Bastardize-1.06 |
426 | |
427 | =item AYRNIEU/Text-Bastardize-1.06.tar.gz |
428 | |
429 | =item http://example.com/Text-Bastardize-1.06.tar.gz |
430 | |
431 | =item file:///tmp/Text-Bastardize-1.06.tar.gz |
432 | |
a0995fd4 |
433 | =item /tmp/Text-Bastardize-1.06 |
434 | |
435 | =item ./Text-Bastardize-1.06 |
436 | |
437 | =item . |
438 | |
6aaee015 |
439 | =back |
440 | |
441 | These items would all come up with a C<CPANPLUS::Module> object for |
442 | C<Text::Bastardize>. The ones marked explicitly as being version 1.06 |
443 | would give back a C<CPANPLUS::Module> object of that version. |
444 | Even if the version on CPAN is currently higher. |
445 | |
a0995fd4 |
446 | The last three are examples of PATH resolution. In the first, we supply |
447 | an absolute path to the unwrapped distribution. In the second the |
448 | distribution is relative to the current working directory. |
449 | In the third, we will use the current working directory. |
450 | |
6aaee015 |
451 | If C<parse_module> is unable to actually find the module you are looking |
452 | for in its module tree, but you supplied it with an author, module |
453 | and version part in a distribution name or URI, it will create a fake |
454 | C<CPANPLUS::Module> object for you, that you can use just like the |
455 | real thing. |
456 | |
457 | See L<CPANPLUS::Module> for the operations you can perform on a |
458 | module object. |
459 | |
460 | If even this fancy guessing doesn't enable C<parse_module> to create |
461 | a fake module object for you to use, it will warn about an error and |
462 | return false. |
463 | |
464 | =cut |
465 | |
466 | sub parse_module { |
467 | my $self = shift; |
468 | my $conf = $self->configure_object; |
469 | my %hash = @_; |
470 | |
471 | my $mod; |
472 | my $tmpl = { |
473 | module => { required => 1, store => \$mod }, |
474 | }; |
475 | |
476 | my $args = check( $tmpl, \%hash ) or return; |
477 | |
478 | return $mod if IS_MODOBJ->( module => $mod ); |
479 | |
480 | ### ok, so it's not a module object, but a ref nonetheless? |
481 | ### what are you smoking? |
482 | if( ref $mod ) { |
483 | error(loc("Can not parse module string from reference '%1'", $mod )); |
484 | return; |
485 | } |
486 | |
487 | ### check only for allowed characters in a module name |
488 | unless( $mod =~ /[^\w:]/ ) { |
489 | |
490 | ### perhaps we can find it in the module tree? |
491 | my $maybe = $self->module_tree($mod); |
492 | return $maybe if IS_MODOBJ->( module => $maybe ); |
493 | } |
494 | |
a0995fd4 |
495 | ### Special case arbitary file paths such as '.' etc. |
496 | if (-d File::Spec->rel2abs($mod) ) { |
497 | my $dir = File::Spec->rel2abs($mod); |
498 | my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) ); |
499 | |
500 | my $dist = $mod = File::Basename::basename($dir); |
501 | $dist .= '-0' unless $dist =~ /\-[0-9._]+$/; |
502 | $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; |
503 | |
504 | my $modobj = CPANPLUS::Module::Fake->new( |
505 | module => $mod, |
506 | version => 0, |
507 | package => $dist, |
508 | path => $parent, |
509 | author => CPANPLUS::Module::Author::Fake->new |
510 | ); |
511 | |
512 | ### better guess for the version |
513 | $modobj->version( $modobj->package_version ) |
514 | if defined $modobj->package_version; |
515 | |
516 | ### better guess at module name, if possible |
517 | if ( my $pkgname = $modobj->package_name ) { |
518 | $pkgname =~ s/-/::/g; |
519 | |
520 | ### no sense replacing it unless we changed something |
521 | $modobj->module( $pkgname ) |
522 | if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; |
523 | } |
524 | |
525 | $modobj->status->fetch( $parent ); |
526 | $modobj->status->extract( $dir ); |
527 | $modobj->get_installer_type; |
528 | return $modobj; |
529 | } |
530 | |
6aaee015 |
531 | ### ok, so it looks like a distribution then? |
532 | my @parts = split '/', $mod; |
533 | my $dist = pop @parts; |
534 | |
535 | ### ah, it's a URL |
536 | if( $mod =~ m|\w+://.+| ) { |
537 | my $modobj = CPANPLUS::Module::Fake->new( |
538 | module => $dist, |
539 | version => 0, |
540 | package => $dist, |
541 | path => File::Spec::Unix->catdir( |
542 | $conf->_get_mirror('base'), |
543 | UNKNOWN_DL_LOCATION ), |
544 | author => CPANPLUS::Module::Author::Fake->new |
545 | ); |
546 | |
547 | ### set the fetch_from accessor so we know to by pass the |
548 | ### usual mirrors |
549 | $modobj->status->_fetch_from( $mod ); |
550 | |
5bc5f6dc |
551 | ### better guess for the version |
552 | $modobj->version( $modobj->package_version ) |
553 | if defined $modobj->package_version; |
554 | |
555 | ### better guess at module name, if possible |
556 | if ( my $pkgname = $modobj->package_name ) { |
557 | $pkgname =~ s/-/::/g; |
558 | |
559 | ### no sense replacing it unless we changed something |
560 | $modobj->module( $pkgname ) |
561 | if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; |
562 | } |
563 | |
6aaee015 |
564 | return $modobj; |
565 | } |
566 | |
567 | ### perhaps we can find it's a third party module? |
568 | { my $modobj = CPANPLUS::Module::Fake->new( |
569 | module => $mod, |
570 | version => 0, |
571 | package => $dist, |
572 | path => File::Spec::Unix->catdir( |
573 | $conf->_get_mirror('base'), |
574 | UNKNOWN_DL_LOCATION ), |
575 | author => CPANPLUS::Module::Author::Fake->new |
576 | ); |
577 | if( $modobj->is_third_party ) { |
578 | my $info = $modobj->third_party_information; |
579 | |
580 | $modobj->author->author( $info->{author} ); |
581 | $modobj->author->email( $info->{author_url} ); |
582 | $modobj->description( $info->{url} ); |
583 | |
584 | return $modobj; |
585 | } |
586 | } |
587 | |
588 | unless( $dist ) { |
589 | error( loc("%1 is not a proper distribution name!", $mod) ); |
590 | return; |
591 | } |
592 | |
593 | ### there's wonky uris out there, like this: |
594 | ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091 |
595 | ### compensate for that |
596 | my $author; |
597 | ### you probably have an A/AB/ABC/....../Dist.tgz type uri |
598 | if( (defined $parts[0] and length $parts[0] == 1) and |
599 | (defined $parts[1] and length $parts[1] == 2) and |
600 | $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i |
601 | ) { |
602 | splice @parts, 0, 2; # remove the first 2 entries from the list |
603 | $author = shift @parts; # this is the actual author name then |
604 | |
605 | ### we''ll assume a ABC/..../Dist.tgz |
606 | } else { |
607 | $author = shift @parts || ''; |
608 | } |
4443dd53 |
609 | |
610 | my($pkg, $version, $ext, $full) = |
6aaee015 |
611 | $self->_split_package_string( package => $dist ); |
612 | |
613 | ### translate a distribution into a module name ### |
614 | my $guess = $pkg; |
615 | $guess =~ s/-/::/g if $guess; |
616 | |
617 | my $maybe = $self->module_tree( $guess ); |
618 | if( IS_MODOBJ->( module => $maybe ) ) { |
619 | |
620 | ### maybe you asked for a package instead |
621 | if ( $maybe->package eq $mod ) { |
622 | return $maybe; |
623 | |
624 | ### perhaps an outdated version instead? |
625 | } elsif ( $version ) { |
626 | my $auth_obj; my $path; |
627 | |
628 | ### did you give us an author part? ### |
629 | if( $author ) { |
630 | $auth_obj = CPANPLUS::Module::Author::Fake->new( |
631 | _id => $maybe->_id, |
632 | cpanid => uc $author, |
633 | author => uc $author, |
634 | ); |
635 | $path = File::Spec::Unix->catdir( |
636 | $conf->_get_mirror('base'), |
637 | substr(uc $author, 0, 1), |
638 | substr(uc $author, 0, 2), |
639 | uc $author, |
640 | @parts, #possible sub dirs |
641 | ); |
642 | } else { |
643 | $auth_obj = $maybe->author; |
644 | $path = $maybe->path; |
645 | } |
646 | |
647 | if( $maybe->package_name eq $pkg ) { |
648 | |
649 | my $modobj = CPANPLUS::Module::Fake->new( |
650 | module => $maybe->module, |
651 | version => $version, |
4443dd53 |
652 | ### no extension? use the extension the original package |
653 | ### had instead |
654 | package => do { $ext |
655 | ? $full |
656 | : $full .'.'. $maybe->package_extension |
657 | }, |
6aaee015 |
658 | path => $path, |
659 | author => $auth_obj, |
660 | _id => $maybe->_id |
661 | ); |
662 | return $modobj; |
663 | |
664 | ### you asked for a specific version? |
665 | ### assume our $maybe is the one you wanted, |
666 | ### and fix up the version.. |
667 | } else { |
668 | |
669 | my $modobj = $maybe->clone; |
670 | $modobj->version( $version ); |
671 | $modobj->package( |
672 | $maybe->package_name .'-'. |
673 | $version .'.'. |
674 | $maybe->package_extension |
675 | ); |
676 | |
677 | ### you wanted a specific author, but it's not the one |
678 | ### from the module tree? we'll fix it up |
679 | if( $author and $author ne $modobj->author->cpanid ) { |
680 | $modobj->author( $auth_obj ); |
681 | $modobj->path( $path ); |
682 | } |
683 | |
684 | return $modobj; |
685 | } |
686 | |
687 | ### you didn't care about a version, so just return the object then |
688 | } elsif ( !$version ) { |
689 | return $maybe; |
690 | } |
691 | |
692 | ### ok, so we can't find it, and it's not an outdated dist either |
693 | ### perhaps we can fake one based on the author name and so on |
694 | } elsif ( $author and $version ) { |
695 | |
696 | ### be extra friendly and pad the .tar.gz suffix where needed |
697 | ### it's just a guess of course, but most dists are .tar.gz |
698 | $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; |
699 | |
700 | ### XXX duplication from above for generating author obj + path... |
701 | my $modobj = CPANPLUS::Module::Fake->new( |
702 | module => $guess, |
703 | version => $version, |
704 | package => $dist, |
705 | author => CPANPLUS::Module::Author::Fake->new( |
706 | author => uc $author, |
707 | cpanid => uc $author, |
708 | _id => $self->_id, |
709 | ), |
710 | path => File::Spec::Unix->catdir( |
711 | $conf->_get_mirror('base'), |
712 | substr(uc $author, 0, 1), |
713 | substr(uc $author, 0, 2), |
714 | uc $author, |
715 | @parts, #possible subdirs |
716 | ), |
717 | _id => $self->_id, |
718 | ); |
719 | |
720 | return $modobj; |
721 | |
722 | ### face it, we have /no/ idea what he or she wants... |
723 | ### let's start putting the blame somewhere |
724 | } else { |
725 | |
726 | unless( $author ) { |
727 | error( loc( "'%1' does not contain an author part", $mod ) ); |
728 | } |
729 | |
730 | error( loc( "Cannot find '%1' in the module tree", $mod ) ); |
731 | } |
732 | |
733 | return; |
734 | } |
735 | |
736 | =pod |
737 | |
738 | =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] ); |
739 | |
740 | This method reloads the source files. |
741 | |
742 | If C<update_source> is set to true, this will fetch new source files |
743 | from your CPAN mirror. Otherwise, C<reload_indices> will do its |
744 | usual cache checking and only update them if they are out of date. |
745 | |
746 | By default, C<update_source> will be false. |
747 | |
748 | The verbose setting defaults to what you have specified in your |
749 | config file. |
750 | |
751 | Returns true on success and false on failure. |
752 | |
753 | =cut |
754 | |
755 | sub reload_indices { |
756 | my $self = shift; |
757 | my %hash = @_; |
758 | my $conf = $self->configure_object; |
759 | |
760 | my $tmpl = { |
761 | update_source => { default => 0, allow => [qr/^\d$/] }, |
762 | verbose => { default => $conf->get_conf('verbose') }, |
763 | }; |
764 | |
765 | my $args = check( $tmpl, \%hash ) or return; |
766 | |
767 | ### make a call to the internal _module_tree, so it triggers cache |
768 | ### file age |
769 | my $uptodate = $self->_check_trees( %$args ); |
770 | |
771 | |
772 | return 1 if $self->_build_trees( |
773 | uptodate => $uptodate, |
774 | use_stored => 0, |
775 | verbose => $conf->get_conf('verbose'), |
776 | ); |
777 | |
778 | error( loc( "Error rebuilding source trees!" ) ); |
779 | |
780 | return; |
781 | } |
782 | |
783 | =pod |
784 | |
785 | =head2 $bool = $cb->flush(CACHE_NAME) |
786 | |
787 | This method allows flushing of caches. |
788 | There are several things which can be flushed: |
789 | |
790 | =over 4 |
791 | |
792 | =item * C<methods> |
793 | |
794 | The return status of methods which have been attempted, such as |
795 | different ways of fetching files. It is recommended that automatic |
796 | flushing be used instead. |
797 | |
798 | =item * C<hosts> |
799 | |
800 | The return status of URIs which have been attempted, such as |
801 | different hosts of fetching files. It is recommended that automatic |
802 | flushing be used instead. |
803 | |
804 | =item * C<modules> |
805 | |
806 | Information about modules such as prerequisites and whether |
807 | installation succeeded, failed, or was not attempted. |
808 | |
809 | =item * C<lib> |
810 | |
811 | This resets PERL5LIB, which is changed to ensure that while installing |
812 | modules they are in our @INC. |
813 | |
814 | =item * C<load> |
815 | |
816 | This resets the cache of modules we've attempted to load, but failed. |
817 | This enables you to load them again after a failed load, if they |
818 | somehow have become available. |
819 | |
820 | =item * C<all> |
821 | |
822 | Flush all of the aforementioned caches. |
823 | |
824 | =back |
825 | |
826 | Returns true on success and false on failure. |
827 | |
828 | =cut |
829 | |
830 | sub flush { |
831 | my $self = shift; |
832 | my $type = shift or return; |
833 | |
834 | my $cache = { |
835 | methods => [ qw( methods load ) ], |
836 | hosts => [ qw( hosts ) ], |
837 | modules => [ qw( modules lib) ], |
838 | lib => [ qw( lib ) ], |
839 | load => [ qw( load ) ], |
840 | all => [ qw( hosts lib modules methods load ) ], |
841 | }; |
842 | |
843 | my $aref = $cache->{$type} |
844 | or ( |
845 | error( loc("No such cache '%1'", $type) ), |
846 | return |
847 | ); |
848 | |
849 | return $self->_flush( list => $aref ); |
850 | } |
851 | |
852 | =pod |
853 | |
854 | =head2 @mods = $cb->installed() |
855 | |
856 | Returns a list of module objects of all your installed modules. |
857 | If an error occurs, it will return false. |
858 | |
859 | See L<CPANPLUS::Module> for the operations you can perform on a |
860 | module object. |
861 | |
862 | =cut |
863 | |
864 | sub installed { |
865 | my $self = shift; |
866 | my $aref = $self->_all_installed; |
867 | |
868 | return @$aref if $aref; |
869 | return; |
870 | } |
871 | |
872 | =pod |
873 | |
874 | =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] ) |
875 | |
876 | Creates a local mirror of CPAN, of only the most recent sources in a |
877 | location you specify. If you set this location equal to a custom host |
878 | in your C<CPANPLUS::Config> you can use your local mirror to install |
879 | from. |
880 | |
881 | It takes the following arguments: |
882 | |
883 | =over 4 |
884 | |
885 | =item path |
886 | |
887 | The location where to create the local mirror. |
888 | |
889 | =item index_files |
890 | |
5bc5f6dc |
891 | Enable/disable fetching of index files. You can disable fetching of the |
892 | index files if you don't plan to use the local mirror as your primary |
893 | site, or if you'd like up-to-date index files be fetched from elsewhere. |
6aaee015 |
894 | |
895 | Defaults to true. |
896 | |
897 | =item force |
898 | |
899 | Forces refetching of packages, even if they are there already. |
900 | |
901 | Defaults to whatever setting you have in your C<CPANPLUS::Config>. |
902 | |
903 | =item verbose |
904 | |
905 | Prints more messages about what its doing. |
906 | |
907 | Defaults to whatever setting you have in your C<CPANPLUS::Config>. |
908 | |
909 | =back |
910 | |
911 | Returns true on success and false on error. |
912 | |
913 | =cut |
914 | |
915 | sub local_mirror { |
916 | my $self = shift; |
917 | my $conf = $self->configure_object; |
918 | my %hash = @_; |
919 | |
920 | my($path, $index, $force, $verbose); |
921 | my $tmpl = { |
922 | path => { default => $conf->get_conf('base'), |
923 | store => \$path }, |
924 | index_files => { default => 1, store => \$index }, |
925 | force => { default => $conf->get_conf('force'), |
926 | store => \$force }, |
927 | verbose => { default => $conf->get_conf('verbose'), |
928 | store => \$verbose }, |
929 | }; |
930 | |
931 | check( $tmpl, \%hash ) or return; |
932 | |
933 | unless( -d $path ) { |
934 | $self->_mkdir( dir => $path ) |
935 | or( error( loc( "Could not create '%1', giving up", $path ) ), |
936 | return |
937 | ); |
938 | } elsif ( ! -w _ ) { |
939 | error( loc( "Could not write to '%1', giving up", $path ) ); |
940 | return; |
941 | } |
942 | |
943 | my $flag; |
944 | AUTHOR: { |
945 | for my $auth ( sort { $a->cpanid cmp $b->cpanid } |
946 | values %{$self->author_tree} |
947 | ) { |
948 | |
949 | MODULE: { |
950 | my $i; |
951 | for my $mod ( $auth->modules ) { |
952 | my $fetchdir = File::Spec->catdir( $path, $mod->path ); |
953 | |
954 | my %opts = ( |
955 | verbose => $verbose, |
956 | force => $force, |
957 | fetchdir => $fetchdir, |
958 | ); |
959 | |
960 | ### only do this the for the first module ### |
961 | unless( $i++ ) { |
962 | $mod->_get_checksums_file( |
963 | %opts |
964 | ) or ( |
965 | error( loc( "Could not fetch %1 file, " . |
966 | "skipping author '%2'", |
967 | CHECKSUMS, $auth->cpanid ) ), |
968 | $flag++, next AUTHOR |
969 | ); |
970 | } |
971 | |
972 | $mod->fetch( %opts ) |
973 | or( error( loc( "Could not fetch '%1'", $mod->module ) ), |
974 | $flag++, next MODULE |
975 | ); |
976 | } } |
977 | } } |
978 | |
979 | if( $index ) { |
980 | for my $name (qw[auth dslip mod]) { |
981 | $self->_update_source( |
982 | name => $name, |
983 | verbose => $verbose, |
984 | path => $path, |
985 | ) or ( $flag++, next ); |
986 | } |
987 | } |
988 | |
989 | return !$flag; |
990 | } |
991 | |
992 | =pod |
993 | |
994 | =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL]) |
995 | |
996 | Writes out a snapshot of your current installation in C<CPAN> bundle |
997 | style. This can then be used to install the same modules for a |
4443dd53 |
998 | different or on a different machine by issuing the following commands: |
999 | |
1000 | ### using the default shell: |
1001 | CPAN Terminal> i file://path/to/Snapshot_XXYY.pm |
1002 | |
1003 | ### using the API |
1004 | $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); |
1005 | $modobj->install; |
6aaee015 |
1006 | |
1007 | It will, by default, write to an 'autobundle' directory under your |
1008 | cpanplus homedirectory, but you can override that by supplying a |
1009 | C<path> argument. |
1010 | |
1011 | It will return the location of the output file on success and false on |
1012 | failure. |
1013 | |
1014 | =cut |
1015 | |
1016 | sub autobundle { |
1017 | my $self = shift; |
1018 | my $conf = $self->configure_object; |
1019 | my %hash = @_; |
1020 | |
1021 | my($path,$force,$verbose); |
1022 | my $tmpl = { |
1023 | force => { default => $conf->get_conf('force'), store => \$force }, |
1024 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
1025 | path => { default => File::Spec->catdir( |
1026 | $conf->get_conf('base'), |
1027 | $self->_perl_version( perl => $^X ), |
1028 | $conf->_get_build('distdir'), |
1029 | $conf->_get_build('autobundle') ), |
1030 | store => \$path }, |
1031 | }; |
1032 | |
1033 | check($tmpl, \%hash) or return; |
1034 | |
1035 | unless( -d $path ) { |
1036 | $self->_mkdir( dir => $path ) |
1037 | or( error(loc("Could not create directory '%1'", $path ) ), |
1038 | return |
1039 | ); |
1040 | } |
1041 | |
1042 | my $name; my $file; |
1043 | { ### default filename for the bundle ### |
1044 | my($year,$month,$day) = (localtime)[5,4,3]; |
1045 | $year += 1900; $month++; |
1046 | |
1047 | my $ext = 0; |
1048 | |
1049 | my $prefix = $conf->_get_build('autobundle_prefix'); |
1050 | my $format = "${prefix}_%04d_%02d_%02d_%02d"; |
1051 | |
1052 | BLOCK: { |
1053 | $name = sprintf( $format, $year, $month, $day, $ext); |
1054 | |
1055 | $file = File::Spec->catfile( $path, $name . '.pm' ); |
1056 | |
1057 | -f $file ? ++$ext && redo BLOCK : last BLOCK; |
1058 | } |
1059 | } |
1060 | my $fh; |
1061 | unless( $fh = FileHandle->new( ">$file" ) ) { |
1062 | error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); |
1063 | return; |
1064 | } |
5bc5f6dc |
1065 | |
1066 | ### make sure we load the module tree *before* doing this, as it |
1067 | ### starts to chdir all over the place |
1068 | $self->module_tree; |
6aaee015 |
1069 | |
1070 | my $string = join "\n\n", |
1071 | map { |
1072 | join ' ', |
1073 | $_->module, |
1074 | ($_->installed_version(verbose => 0) || 'undef') |
1075 | } sort { |
1076 | $a->module cmp $b->module |
1077 | } $self->installed; |
1078 | |
1079 | my $now = scalar localtime; |
1080 | my $head = '=head1'; |
1081 | my $pkg = __PACKAGE__; |
1082 | my $version = $self->VERSION; |
1083 | my $perl_v = join '', `$^X -V`; |
1084 | |
1085 | print $fh <<EOF; |
4443dd53 |
1086 | package $name; |
6aaee015 |
1087 | |
1088 | \$VERSION = '0.01'; |
1089 | |
1090 | 1; |
1091 | |
1092 | __END__ |
1093 | |
1094 | $head NAME |
1095 | |
1096 | $name - Snapshot of your installation at $now |
1097 | |
1098 | $head SYNOPSIS |
1099 | |
4443dd53 |
1100 | perl -MCPANPLUS -e "install file://full/path/to/$name" |
6aaee015 |
1101 | |
1102 | $head CONTENTS |
1103 | |
1104 | $string |
1105 | |
1106 | $head CONFIGURATION |
1107 | |
1108 | $perl_v |
1109 | |
1110 | $head AUTHOR |
1111 | |
1112 | This bundle has been generated autotomatically by |
1113 | $pkg $version |
1114 | |
1115 | EOF |
1116 | |
1117 | close $fh; |
1118 | |
1119 | return $file; |
1120 | } |
1121 | |
4443dd53 |
1122 | =head2 $bool = $cb->save_state |
1123 | |
1124 | Explicit command to save memory state to disk. This can be used to save |
1125 | information to disk about where a module was extracted, the result of |
1126 | C<make test>, etc. This will then be re-loaded into memory when a new |
1127 | session starts. |
1128 | |
1129 | The capability of saving state to disk depends on the source engine |
1130 | being used (See C<CPANPLUS::Config> for the option to choose your |
1131 | source engine). The default storage engine supports this option. |
1132 | |
1133 | Most users will not need this command, but it can handy for automated |
1134 | systems like setting up CPAN smoke testers. |
1135 | |
1136 | The method will return true if it managed to save the state to disk, |
1137 | or false if it did not. |
1138 | |
1139 | =cut |
1140 | |
1141 | sub save_state { |
1142 | my $self = shift; |
1143 | return $self->_save_state( @_ ); |
1144 | } |
1145 | |
1146 | |
5bc5f6dc |
1147 | ### XXX these wrappers are not individually tested! only the underlying |
1148 | ### code through source.t and indirectly trought he CustomSource plugin. |
1149 | =pod |
1150 | |
1151 | =head1 CUSTOM MODULE SOURCES |
1152 | |
1153 | Besides the sources as provided by the general C<CPAN> mirrors, it's |
1154 | possible to add your own sources list to your C<CPANPLUS> index. |
1155 | |
1156 | The methodology behind this works much like C<Debian's apt-sources>. |
1157 | |
1158 | The methods below show you how to make use of this functionality. Also |
1159 | note that most of these methods are available through the default shell |
1160 | plugin command C</cs>, making them available as shortcuts through the |
1161 | shell and via the commandline. |
1162 | |
1163 | =head2 %files = $cb->list_custom_sources |
1164 | |
1165 | Returns a mapping of registered custom sources and their local indices |
1166 | as follows: |
1167 | |
1168 | /full/path/to/local/index => http://remote/source |
1169 | |
1170 | Note that any file starting with an C<#> is being ignored. |
1171 | |
1172 | =cut |
1173 | |
1174 | sub list_custom_sources { |
1175 | return shift->__list_custom_module_sources( @_ ); |
1176 | } |
1177 | |
1178 | =head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] ); |
1179 | |
1180 | Adds an C<URI> to your own sources list and mirrors its index. See the |
1181 | documentation on C<< $cb->update_custom_source >> on how this is done. |
1182 | |
1183 | Returns the full path to the local index on success, or false on failure. |
1184 | |
1185 | Note that when adding a new C<URI>, the change to the in-memory tree is |
1186 | not saved until you rebuild or save the tree to disk again. You can do |
1187 | this using the C<< $cb->reload_indices >> method. |
1188 | |
1189 | =cut |
1190 | |
1191 | sub add_custom_source { |
1192 | return shift->_add_custom_module_source( @_ ); |
1193 | } |
1194 | |
1195 | =head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] ); |
1196 | |
1197 | Removes an C<URI> from your own sources list and removes its index. |
1198 | |
1199 | To find out what C<URI>s you have as part of your own sources list, use |
1200 | the C<< $cb->list_custom_sources >> method. |
1201 | |
1202 | Returns the full path to the deleted local index file on success, or false |
1203 | on failure. |
1204 | |
1205 | =cut |
1206 | |
1207 | ### XXX do clever dispatching based on arg number? |
1208 | sub remove_custom_source { |
1209 | return shift->_remove_custom_module_source( @_ ); |
1210 | } |
1211 | |
1212 | =head2 $bool = $cb->update_custom_source( [remote => URI] ); |
1213 | |
1214 | Updates the indexes for all your custom sources. It does this by fetching |
1215 | a file called C<packages.txt> in the root of the custom sources's C<URI>. |
1216 | If you provide the C<remote> argument, it will only update the index for |
1217 | that specific C<URI>. |
1218 | |
1219 | Here's an example of how custom sources would resolve into index files: |
1220 | |
1221 | file:///path/to/sources => file:///path/to/sources/packages.txt |
1222 | http://example.com/sources => http://example.com/sources/packages.txt |
1223 | ftp://example.com/sources => ftp://example.com/sources/packages.txt |
1224 | |
1225 | The file C<packages.txt> simply holds a list of packages that can be found |
1226 | under the root of the C<URI>. This file can be automatically generated for |
1227 | you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>, |
1228 | and similar, the administrator of that repository should run the method |
1229 | C<< $cb->write_custom_source_index >> on the repository to allow remote |
1230 | users to index it. |
1231 | |
1232 | For details, see the C<< $cb->write_custom_source_index >> method below. |
1233 | |
1234 | All packages that are added via this mechanism will be attributed to the |
1235 | author with C<CPANID> C<LOCAL>. You can use this id to search for all |
1236 | added packages. |
1237 | |
1238 | =cut |
1239 | |
1240 | sub update_custom_source { |
1241 | my $self = shift; |
1242 | |
1243 | ### if it mentions /remote/, the request is to update a single uri, |
1244 | ### not all the ones we have, so dispatch appropriately |
1245 | my $rv = grep( /remote/i, @_) |
1246 | ? $self->__update_custom_module_source( @_ ) |
1247 | : $self->__update_custom_module_sources( @_ ); |
1248 | |
1249 | return $rv; |
1250 | } |
1251 | |
1252 | =head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] ); |
1253 | |
1254 | Writes the index for a custom repository root. Most users will not have to |
1255 | worry about this, but administrators of a repository will need to make sure |
1256 | their indexes are up to date. |
1257 | |
1258 | The index will be written to a file called C<packages.txt> in your repository |
1259 | root, which you can specify with the C<path> argument. You can override this |
1260 | location by specifying the C<to> argument, but in normal operation, that should |
1261 | not be required. |
1262 | |
1263 | Once the index file is written, users can then add the C<URI> pointing to |
1264 | the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details. |
1265 | |
1266 | =cut |
1267 | |
1268 | sub write_custom_source_index { |
1269 | return shift->__write_custom_module_index( @_ ); |
1270 | } |
1271 | |
6aaee015 |
1272 | 1; |
1273 | |
1274 | =pod |
1275 | |
1276 | =head1 BUG REPORTS |
1277 | |
1278 | Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. |
1279 | |
1280 | =head1 AUTHOR |
1281 | |
1282 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
1283 | |
1284 | =head1 COPYRIGHT |
1285 | |
1286 | The CPAN++ interface (of which this module is a part of) is copyright (c) |
1287 | 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. |
1288 | |
1289 | This library is free software; you may redistribute and/or modify it |
1290 | under the same terms as Perl itself. |
1291 | |
1292 | =head1 SEE ALSO |
1293 | |
5bc5f6dc |
1294 | L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>, |
1295 | L<CPANPLUS::Selfupdate> |
6aaee015 |
1296 | |
1297 | =cut |
1298 | |
1299 | # Local variables: |
1300 | # c-indentation-style: bsd |
1301 | # c-basic-offset: 4 |
1302 | # indent-tabs-mode: nil |
1303 | # End: |
1304 | # vim: expandtab shiftwidth=4: |
1305 | |
1306 | __END__ |
1307 | |
1308 | todo: |
1309 | sub dist { # not sure about this one -- probably already done |
1310 | enough in Module.pm |
1311 | sub reports { # in Module.pm, wrapper here |
1312 | |
1313 | |