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 (); |
17 | use Params::Check qw[check]; |
18 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
19 | |
20 | $Params::Check::VERBOSE = 1; |
21 | |
22 | use vars qw[@ISA $VERSION]; |
23 | |
24 | @ISA = qw[CPANPLUS::Internals]; |
25 | $VERSION = $CPANPLUS::Internals::VERSION; |
26 | |
27 | ### mark that we're running under CPANPLUS to spawned processes |
28 | $ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$; |
29 | |
30 | ### XXX version.pm MAY format this version, if it's in use... :( |
31 | ### so for consistency, just call ->VERSION ourselves as well. |
32 | $ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION; |
33 | |
34 | =pod |
35 | |
36 | =head1 NAME |
37 | |
38 | CPANPLUS::Backend |
39 | |
40 | =head1 SYNOPSIS |
41 | |
42 | my $cb = CPANPLUS::Backend->new( ); |
43 | my $conf = $cb->configure_object; |
44 | |
45 | my $author = $cb->author_tree('KANE'); |
46 | my $mod = $cb->module_tree('Some::Module'); |
47 | my $mod = $cb->parse_module( module => 'Some::Module' ); |
48 | |
49 | my @objs = $cb->search( type => TYPE, |
50 | allow => [...] ); |
51 | |
52 | $cb->flush('all'); |
53 | $cb->reload_indices; |
54 | $cb->local_mirror; |
55 | |
56 | |
57 | =head1 DESCRIPTION |
58 | |
59 | This module provides the programmer's interface to the C<CPANPLUS> |
60 | libraries. |
61 | |
62 | =head1 ENVIRONMENT |
63 | |
64 | When C<CPANPLUS::Backend> is loaded, which is necessary for just |
65 | about every <CPANPLUS> operation, the environment variable |
66 | C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id. |
67 | |
68 | Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> |
69 | will be set to the version of C<CPANPLUS::Backend>. |
70 | |
71 | This information might be useful somehow to spawned processes. |
72 | |
73 | =head1 METHODS |
74 | |
75 | =head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) |
76 | |
77 | This method returns a new C<CPANPLUS::Backend> object. |
78 | This also initialises the config corresponding to this object. |
79 | You have two choices in this: |
80 | |
81 | =over 4 |
82 | |
83 | =item Provide a valid C<CPANPLUS::Configure> object |
84 | |
85 | This will be used verbatim. |
86 | |
87 | =item No arguments |
88 | |
89 | Your default config will be loaded and used. |
90 | |
91 | =back |
92 | |
93 | New will return a C<CPANPLUS::Backend> object on success and die on |
94 | failure. |
95 | |
96 | =cut |
97 | |
98 | sub new { |
99 | my $class = shift; |
100 | my $conf; |
101 | |
102 | if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) { |
103 | $conf = shift; |
104 | } else { |
105 | $conf = CPANPLUS::Configure->new() or return; |
106 | } |
107 | |
108 | my $self = $class->SUPER::_init( _conf => $conf ); |
109 | |
110 | return $self; |
111 | } |
112 | |
113 | =pod |
114 | |
115 | =head2 $href = $cb->module_tree( [@modules_names_list] ) |
116 | |
117 | Returns a reference to the CPANPLUS module tree. |
118 | |
119 | If you give it any arguments, they will be treated as module names |
120 | and C<module_tree> will try to look up these module names and |
121 | return the corresponding module objects instead. |
122 | |
123 | See L<CPANPLUS::Module> for the operations you can perform on a |
124 | module object. |
125 | |
126 | =cut |
127 | |
128 | sub module_tree { |
129 | my $self = shift; |
130 | my $modtree = $self->_module_tree; |
131 | |
132 | if( @_ ) { |
133 | my @rv; |
134 | for my $name ( grep { defined } @_) { |
135 | push @rv, $modtree->{$name} || ''; |
136 | } |
137 | return @rv == 1 ? $rv[0] : @rv; |
138 | } else { |
139 | return $modtree; |
140 | } |
141 | } |
142 | |
143 | =pod |
144 | |
145 | =head2 $href = $cb->author_tree( [@author_names_list] ) |
146 | |
147 | Returns a reference to the CPANPLUS author tree. |
148 | |
149 | If you give it any arguments, they will be treated as author names |
150 | and C<author_tree> will try to look up these author names and |
151 | return the corresponding author objects instead. |
152 | |
153 | See L<CPANPLUS::Module::Author> for the operations you can perform on |
154 | an author object. |
155 | |
156 | =cut |
157 | |
158 | sub author_tree { |
159 | my $self = shift; |
160 | my $authtree = $self->_author_tree; |
161 | |
162 | if( @_ ) { |
163 | my @rv; |
164 | for my $name (@_) { |
165 | push @rv, $authtree->{$name} || ''; |
166 | } |
167 | return @rv == 1 ? $rv[0] : @rv; |
168 | } else { |
169 | return $authtree; |
170 | } |
171 | } |
172 | |
173 | =pod |
174 | |
175 | =head2 $conf = $cb->configure_object () |
176 | |
177 | Returns a copy of the C<CPANPLUS::Configure> object. |
178 | |
179 | See L<CPANPLUS::Configure> for operations you can perform on a |
180 | configure object. |
181 | |
182 | =cut |
183 | |
184 | sub configure_object { return shift->_conf() }; |
185 | |
186 | =head2 $su = $cb->selfupdate_object; |
187 | |
188 | Returns a copy of the C<CPANPLUS::Selfupdate> object. |
189 | |
190 | See the L<CPANPLUS::Selfupdate> manpage for the operations |
191 | you can perform on the selfupdate object. |
192 | |
193 | =cut |
194 | |
195 | sub selfupdate_object { return shift->_selfupdate() }; |
196 | |
197 | =pod |
198 | |
199 | =head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] ) |
200 | |
201 | C<search> enables you to search for either module or author objects, |
202 | based on their data. The C<type> you can specify is any of the |
203 | accessors specified in C<CPANPLUS::Module::Author> or |
204 | C<CPANPLUS::Module>. C<search> will determine by the C<type> you |
205 | specified whether to search by author object or module object. |
206 | |
207 | You have to specify an array reference of regular expressions or |
208 | strings to match against. The rules used for this array ref are the |
209 | same as in C<Params::Check>, so read that manpage for details. |
210 | |
211 | The search is an C<or> search, meaning that if C<any> of the criteria |
212 | match, the search is considered to be successful. |
213 | |
214 | You can specify the result of a previous search as C<data> to limit |
215 | the new search to these module or author objects, rather than the |
216 | entire module or author tree. This is how you do C<and> searches. |
217 | |
218 | Returns a list of module or author objects on success and false |
219 | on failure. |
220 | |
221 | See L<CPANPLUS::Module> for the operations you can perform on a |
222 | module object. |
223 | See L<CPANPLUS::Module::Author> for the operations you can perform on |
224 | an author object. |
225 | |
226 | =cut |
227 | |
228 | sub search { |
229 | my $self = shift; |
230 | my $conf = $self->configure_object; |
231 | my %hash = @_; |
232 | |
233 | local $Params::Check::ALLOW_UNKNOWN = 1; |
234 | |
235 | my ($data,$type); |
236 | my $tmpl = { |
237 | type => { required => 1, allow => [CPANPLUS::Module->accessors(), |
238 | CPANPLUS::Module::Author->accessors()], store => \$type }, |
239 | allow => { required => 1, default => [ ], strict_type => 1 }, |
240 | }; |
241 | |
242 | my $args = check( $tmpl, \%hash ) or return; |
243 | |
244 | ### figure out whether it was an author or a module search |
245 | ### when ambiguous, it'll be an author search. |
246 | my $aref; |
247 | if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) { |
248 | $aref = $self->_search_author_tree( %$args ); |
249 | } else { |
250 | $aref = $self->_search_module_tree( %$args ); |
251 | } |
252 | |
253 | return @$aref if $aref; |
254 | return; |
255 | } |
256 | |
257 | =pod |
258 | |
259 | =head2 $backend_rv = $cb->fetch( modules => \@mods ) |
260 | |
261 | Fetches a list of modules. C<@mods> can be a list of distribution |
262 | names, module names or module objects--basically anything that |
263 | L<parse_module> can understand. |
264 | |
265 | See the equivalent method in C<CPANPLUS::Module> for details on |
266 | other options you can pass. |
267 | |
268 | Since this is a multi-module method call, the return value is |
269 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
270 | that module's documentation on how to interpret the return value. |
271 | |
272 | =head2 $backend_rv = $cb->extract( modules => \@mods ) |
273 | |
274 | Extracts a list of modules. C<@mods> can be a list of distribution |
275 | names, module names or module objects--basically anything that |
276 | L<parse_module> can understand. |
277 | |
278 | See the equivalent method in C<CPANPLUS::Module> for details on |
279 | other options you can pass. |
280 | |
281 | Since this is a multi-module method call, the return value is |
282 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
283 | that module's documentation on how to interpret the return value. |
284 | |
285 | =head2 $backend_rv = $cb->install( modules => \@mods ) |
286 | |
287 | Installs a list of modules. C<@mods> can be a list of distribution |
288 | names, module names or module objects--basically anything that |
289 | L<parse_module> can understand. |
290 | |
291 | See the equivalent method in C<CPANPLUS::Module> for details on |
292 | other options you can pass. |
293 | |
294 | Since this is a multi-module method call, the return value is |
295 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
296 | that module's documentation on how to interpret the return value. |
297 | |
298 | =head2 $backend_rv = $cb->readme( modules => \@mods ) |
299 | |
300 | Fetches the readme for a list of modules. C<@mods> can be a list of |
301 | distribution names, module names or module objects--basically |
302 | anything that L<parse_module> can understand. |
303 | |
304 | See the equivalent method in C<CPANPLUS::Module> for details on |
305 | other options you can pass. |
306 | |
307 | Since this is a multi-module method call, the return value is |
308 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
309 | that module's documentation on how to interpret the return value. |
310 | |
311 | =head2 $backend_rv = $cb->files( modules => \@mods ) |
312 | |
313 | Returns a list of files used by these modules if they are installed. |
314 | C<@mods> can be a list of distribution names, module names or module |
315 | objects--basically anything that L<parse_module> can understand. |
316 | |
317 | See the equivalent method in C<CPANPLUS::Module> for details on |
318 | other options you can pass. |
319 | |
320 | Since this is a multi-module method call, the return value is |
321 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
322 | that module's documentation on how to interpret the return value. |
323 | |
324 | =head2 $backend_rv = $cb->distributions( modules => \@mods ) |
325 | |
326 | Returns a list of module objects representing all releases for this |
327 | module on success. |
328 | C<@mods> can be a list of distribution names, module names or module |
329 | objects, basically anything that L<parse_module> can understand. |
330 | |
331 | See the equivalent method in C<CPANPLUS::Module> for details on |
332 | other options you can pass. |
333 | |
334 | Since this is a multi-module method call, the return value is |
335 | implemented as a C<CPANPLUS::Backend::RV> object. Please consult |
336 | that module's documentation on how to interpret the return value. |
337 | |
338 | =cut |
339 | |
340 | ### XXX add direcotry_tree, packlist etc? or maybe remove files? ### |
341 | for my $func (qw[fetch extract install readme files distributions]) { |
342 | no strict 'refs'; |
343 | |
344 | *$func = sub { |
345 | my $self = shift; |
346 | my $conf = $self->configure_object; |
347 | my %hash = @_; |
348 | |
349 | local $Params::Check::NO_DUPLICATES = 1; |
350 | local $Params::Check::ALLOW_UNKNOWN = 1; |
351 | |
352 | my ($mods); |
353 | my $tmpl = { |
354 | modules => { default => [], strict_type => 1, |
355 | required => 1, store => \$mods }, |
356 | }; |
357 | |
358 | my $args = check( $tmpl, \%hash ) or return; |
359 | |
360 | ### make them all into module objects ### |
361 | my %mods = map {$_ => $self->parse_module(module => $_) || ''} @$mods; |
362 | |
363 | my $flag; my $href; |
364 | while( my($name,$obj) = each %mods ) { |
365 | $href->{$name} = IS_MODOBJ->( mod => $obj ) |
366 | ? $obj->$func( %$args ) |
367 | : undef; |
368 | |
369 | $flag++ unless $href->{$name}; |
370 | } |
371 | |
372 | return CPANPLUS::Backend::RV->new( |
373 | function => $func, |
374 | ok => !$flag, |
375 | rv => $href, |
376 | args => \%hash, |
377 | ); |
378 | } |
379 | } |
380 | |
381 | =pod |
382 | |
383 | =head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj ) |
384 | |
385 | C<parse_module> tries to find a C<CPANPLUS::Module> object that |
386 | matches your query. Here's a list of examples you could give to |
387 | C<parse_module>; |
388 | |
389 | =over 4 |
390 | |
391 | =item Text::Bastardize |
392 | |
393 | =item Text-Bastardize |
394 | |
395 | =item Text-Bastardize-1.06 |
396 | |
397 | =item AYRNIEU/Text-Bastardize |
398 | |
399 | =item AYRNIEU/Text-Bastardize-1.06 |
400 | |
401 | =item AYRNIEU/Text-Bastardize-1.06.tar.gz |
402 | |
403 | =item http://example.com/Text-Bastardize-1.06.tar.gz |
404 | |
405 | =item file:///tmp/Text-Bastardize-1.06.tar.gz |
406 | |
407 | =back |
408 | |
409 | These items would all come up with a C<CPANPLUS::Module> object for |
410 | C<Text::Bastardize>. The ones marked explicitly as being version 1.06 |
411 | would give back a C<CPANPLUS::Module> object of that version. |
412 | Even if the version on CPAN is currently higher. |
413 | |
414 | If C<parse_module> is unable to actually find the module you are looking |
415 | for in its module tree, but you supplied it with an author, module |
416 | and version part in a distribution name or URI, it will create a fake |
417 | C<CPANPLUS::Module> object for you, that you can use just like the |
418 | real thing. |
419 | |
420 | See L<CPANPLUS::Module> for the operations you can perform on a |
421 | module object. |
422 | |
423 | If even this fancy guessing doesn't enable C<parse_module> to create |
424 | a fake module object for you to use, it will warn about an error and |
425 | return false. |
426 | |
427 | =cut |
428 | |
429 | sub parse_module { |
430 | my $self = shift; |
431 | my $conf = $self->configure_object; |
432 | my %hash = @_; |
433 | |
434 | my $mod; |
435 | my $tmpl = { |
436 | module => { required => 1, store => \$mod }, |
437 | }; |
438 | |
439 | my $args = check( $tmpl, \%hash ) or return; |
440 | |
441 | return $mod if IS_MODOBJ->( module => $mod ); |
442 | |
443 | ### ok, so it's not a module object, but a ref nonetheless? |
444 | ### what are you smoking? |
445 | if( ref $mod ) { |
446 | error(loc("Can not parse module string from reference '%1'", $mod )); |
447 | return; |
448 | } |
449 | |
450 | ### check only for allowed characters in a module name |
451 | unless( $mod =~ /[^\w:]/ ) { |
452 | |
453 | ### perhaps we can find it in the module tree? |
454 | my $maybe = $self->module_tree($mod); |
455 | return $maybe if IS_MODOBJ->( module => $maybe ); |
456 | } |
457 | |
458 | ### ok, so it looks like a distribution then? |
459 | my @parts = split '/', $mod; |
460 | my $dist = pop @parts; |
461 | |
462 | ### ah, it's a URL |
463 | if( $mod =~ m|\w+://.+| ) { |
464 | my $modobj = CPANPLUS::Module::Fake->new( |
465 | module => $dist, |
466 | version => 0, |
467 | package => $dist, |
468 | path => File::Spec::Unix->catdir( |
469 | $conf->_get_mirror('base'), |
470 | UNKNOWN_DL_LOCATION ), |
471 | author => CPANPLUS::Module::Author::Fake->new |
472 | ); |
473 | |
474 | ### set the fetch_from accessor so we know to by pass the |
475 | ### usual mirrors |
476 | $modobj->status->_fetch_from( $mod ); |
477 | |
478 | return $modobj; |
479 | } |
480 | |
481 | ### perhaps we can find it's a third party module? |
482 | { my $modobj = CPANPLUS::Module::Fake->new( |
483 | module => $mod, |
484 | version => 0, |
485 | package => $dist, |
486 | path => File::Spec::Unix->catdir( |
487 | $conf->_get_mirror('base'), |
488 | UNKNOWN_DL_LOCATION ), |
489 | author => CPANPLUS::Module::Author::Fake->new |
490 | ); |
491 | if( $modobj->is_third_party ) { |
492 | my $info = $modobj->third_party_information; |
493 | |
494 | $modobj->author->author( $info->{author} ); |
495 | $modobj->author->email( $info->{author_url} ); |
496 | $modobj->description( $info->{url} ); |
497 | |
498 | return $modobj; |
499 | } |
500 | } |
501 | |
502 | unless( $dist ) { |
503 | error( loc("%1 is not a proper distribution name!", $mod) ); |
504 | return; |
505 | } |
506 | |
507 | ### there's wonky uris out there, like this: |
508 | ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091 |
509 | ### compensate for that |
510 | my $author; |
511 | ### you probably have an A/AB/ABC/....../Dist.tgz type uri |
512 | if( (defined $parts[0] and length $parts[0] == 1) and |
513 | (defined $parts[1] and length $parts[1] == 2) and |
514 | $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i |
515 | ) { |
516 | splice @parts, 0, 2; # remove the first 2 entries from the list |
517 | $author = shift @parts; # this is the actual author name then |
518 | |
519 | ### we''ll assume a ABC/..../Dist.tgz |
520 | } else { |
521 | $author = shift @parts || ''; |
522 | } |
523 | |
524 | my($pkg, $version, $ext) = |
525 | $self->_split_package_string( package => $dist ); |
526 | |
527 | ### translate a distribution into a module name ### |
528 | my $guess = $pkg; |
529 | $guess =~ s/-/::/g if $guess; |
530 | |
531 | my $maybe = $self->module_tree( $guess ); |
532 | if( IS_MODOBJ->( module => $maybe ) ) { |
533 | |
534 | ### maybe you asked for a package instead |
535 | if ( $maybe->package eq $mod ) { |
536 | return $maybe; |
537 | |
538 | ### perhaps an outdated version instead? |
539 | } elsif ( $version ) { |
540 | my $auth_obj; my $path; |
541 | |
542 | ### did you give us an author part? ### |
543 | if( $author ) { |
544 | $auth_obj = CPANPLUS::Module::Author::Fake->new( |
545 | _id => $maybe->_id, |
546 | cpanid => uc $author, |
547 | author => uc $author, |
548 | ); |
549 | $path = File::Spec::Unix->catdir( |
550 | $conf->_get_mirror('base'), |
551 | substr(uc $author, 0, 1), |
552 | substr(uc $author, 0, 2), |
553 | uc $author, |
554 | @parts, #possible sub dirs |
555 | ); |
556 | } else { |
557 | $auth_obj = $maybe->author; |
558 | $path = $maybe->path; |
559 | } |
560 | |
561 | if( $maybe->package_name eq $pkg ) { |
562 | |
563 | my $modobj = CPANPLUS::Module::Fake->new( |
564 | module => $maybe->module, |
565 | version => $version, |
566 | package => $pkg . '-' . $version . '.' . |
567 | $maybe->package_extension, |
568 | path => $path, |
569 | author => $auth_obj, |
570 | _id => $maybe->_id |
571 | ); |
572 | return $modobj; |
573 | |
574 | ### you asked for a specific version? |
575 | ### assume our $maybe is the one you wanted, |
576 | ### and fix up the version.. |
577 | } else { |
578 | |
579 | my $modobj = $maybe->clone; |
580 | $modobj->version( $version ); |
581 | $modobj->package( |
582 | $maybe->package_name .'-'. |
583 | $version .'.'. |
584 | $maybe->package_extension |
585 | ); |
586 | |
587 | ### you wanted a specific author, but it's not the one |
588 | ### from the module tree? we'll fix it up |
589 | if( $author and $author ne $modobj->author->cpanid ) { |
590 | $modobj->author( $auth_obj ); |
591 | $modobj->path( $path ); |
592 | } |
593 | |
594 | return $modobj; |
595 | } |
596 | |
597 | ### you didn't care about a version, so just return the object then |
598 | } elsif ( !$version ) { |
599 | return $maybe; |
600 | } |
601 | |
602 | ### ok, so we can't find it, and it's not an outdated dist either |
603 | ### perhaps we can fake one based on the author name and so on |
604 | } elsif ( $author and $version ) { |
605 | |
606 | ### be extra friendly and pad the .tar.gz suffix where needed |
607 | ### it's just a guess of course, but most dists are .tar.gz |
608 | $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; |
609 | |
610 | ### XXX duplication from above for generating author obj + path... |
611 | my $modobj = CPANPLUS::Module::Fake->new( |
612 | module => $guess, |
613 | version => $version, |
614 | package => $dist, |
615 | author => CPANPLUS::Module::Author::Fake->new( |
616 | author => uc $author, |
617 | cpanid => uc $author, |
618 | _id => $self->_id, |
619 | ), |
620 | path => File::Spec::Unix->catdir( |
621 | $conf->_get_mirror('base'), |
622 | substr(uc $author, 0, 1), |
623 | substr(uc $author, 0, 2), |
624 | uc $author, |
625 | @parts, #possible subdirs |
626 | ), |
627 | _id => $self->_id, |
628 | ); |
629 | |
630 | return $modobj; |
631 | |
632 | ### face it, we have /no/ idea what he or she wants... |
633 | ### let's start putting the blame somewhere |
634 | } else { |
635 | |
636 | unless( $author ) { |
637 | error( loc( "'%1' does not contain an author part", $mod ) ); |
638 | } |
639 | |
640 | error( loc( "Cannot find '%1' in the module tree", $mod ) ); |
641 | } |
642 | |
643 | return; |
644 | } |
645 | |
646 | =pod |
647 | |
648 | =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] ); |
649 | |
650 | This method reloads the source files. |
651 | |
652 | If C<update_source> is set to true, this will fetch new source files |
653 | from your CPAN mirror. Otherwise, C<reload_indices> will do its |
654 | usual cache checking and only update them if they are out of date. |
655 | |
656 | By default, C<update_source> will be false. |
657 | |
658 | The verbose setting defaults to what you have specified in your |
659 | config file. |
660 | |
661 | Returns true on success and false on failure. |
662 | |
663 | =cut |
664 | |
665 | sub reload_indices { |
666 | my $self = shift; |
667 | my %hash = @_; |
668 | my $conf = $self->configure_object; |
669 | |
670 | my $tmpl = { |
671 | update_source => { default => 0, allow => [qr/^\d$/] }, |
672 | verbose => { default => $conf->get_conf('verbose') }, |
673 | }; |
674 | |
675 | my $args = check( $tmpl, \%hash ) or return; |
676 | |
677 | ### make a call to the internal _module_tree, so it triggers cache |
678 | ### file age |
679 | my $uptodate = $self->_check_trees( %$args ); |
680 | |
681 | |
682 | return 1 if $self->_build_trees( |
683 | uptodate => $uptodate, |
684 | use_stored => 0, |
685 | verbose => $conf->get_conf('verbose'), |
686 | ); |
687 | |
688 | error( loc( "Error rebuilding source trees!" ) ); |
689 | |
690 | return; |
691 | } |
692 | |
693 | =pod |
694 | |
695 | =head2 $bool = $cb->flush(CACHE_NAME) |
696 | |
697 | This method allows flushing of caches. |
698 | There are several things which can be flushed: |
699 | |
700 | =over 4 |
701 | |
702 | =item * C<methods> |
703 | |
704 | The return status of methods which have been attempted, such as |
705 | different ways of fetching files. It is recommended that automatic |
706 | flushing be used instead. |
707 | |
708 | =item * C<hosts> |
709 | |
710 | The return status of URIs which have been attempted, such as |
711 | different hosts of fetching files. It is recommended that automatic |
712 | flushing be used instead. |
713 | |
714 | =item * C<modules> |
715 | |
716 | Information about modules such as prerequisites and whether |
717 | installation succeeded, failed, or was not attempted. |
718 | |
719 | =item * C<lib> |
720 | |
721 | This resets PERL5LIB, which is changed to ensure that while installing |
722 | modules they are in our @INC. |
723 | |
724 | =item * C<load> |
725 | |
726 | This resets the cache of modules we've attempted to load, but failed. |
727 | This enables you to load them again after a failed load, if they |
728 | somehow have become available. |
729 | |
730 | =item * C<all> |
731 | |
732 | Flush all of the aforementioned caches. |
733 | |
734 | =back |
735 | |
736 | Returns true on success and false on failure. |
737 | |
738 | =cut |
739 | |
740 | sub flush { |
741 | my $self = shift; |
742 | my $type = shift or return; |
743 | |
744 | my $cache = { |
745 | methods => [ qw( methods load ) ], |
746 | hosts => [ qw( hosts ) ], |
747 | modules => [ qw( modules lib) ], |
748 | lib => [ qw( lib ) ], |
749 | load => [ qw( load ) ], |
750 | all => [ qw( hosts lib modules methods load ) ], |
751 | }; |
752 | |
753 | my $aref = $cache->{$type} |
754 | or ( |
755 | error( loc("No such cache '%1'", $type) ), |
756 | return |
757 | ); |
758 | |
759 | return $self->_flush( list => $aref ); |
760 | } |
761 | |
762 | =pod |
763 | |
764 | =head2 @mods = $cb->installed() |
765 | |
766 | Returns a list of module objects of all your installed modules. |
767 | If an error occurs, it will return false. |
768 | |
769 | See L<CPANPLUS::Module> for the operations you can perform on a |
770 | module object. |
771 | |
772 | =cut |
773 | |
774 | sub installed { |
775 | my $self = shift; |
776 | my $aref = $self->_all_installed; |
777 | |
778 | return @$aref if $aref; |
779 | return; |
780 | } |
781 | |
782 | =pod |
783 | |
784 | =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] ) |
785 | |
786 | Creates a local mirror of CPAN, of only the most recent sources in a |
787 | location you specify. If you set this location equal to a custom host |
788 | in your C<CPANPLUS::Config> you can use your local mirror to install |
789 | from. |
790 | |
791 | It takes the following arguments: |
792 | |
793 | =over 4 |
794 | |
795 | =item path |
796 | |
797 | The location where to create the local mirror. |
798 | |
799 | =item index_files |
800 | |
801 | Enable/disable fetching of index files. This is ok if you don't plan |
802 | to use the local mirror as your primary sites, or if you'd like |
803 | up-to-date index files be fetched from elsewhere. |
804 | |
805 | Defaults to true. |
806 | |
807 | =item force |
808 | |
809 | Forces refetching of packages, even if they are there already. |
810 | |
811 | Defaults to whatever setting you have in your C<CPANPLUS::Config>. |
812 | |
813 | =item verbose |
814 | |
815 | Prints more messages about what its doing. |
816 | |
817 | Defaults to whatever setting you have in your C<CPANPLUS::Config>. |
818 | |
819 | =back |
820 | |
821 | Returns true on success and false on error. |
822 | |
823 | =cut |
824 | |
825 | sub local_mirror { |
826 | my $self = shift; |
827 | my $conf = $self->configure_object; |
828 | my %hash = @_; |
829 | |
830 | my($path, $index, $force, $verbose); |
831 | my $tmpl = { |
832 | path => { default => $conf->get_conf('base'), |
833 | store => \$path }, |
834 | index_files => { default => 1, store => \$index }, |
835 | force => { default => $conf->get_conf('force'), |
836 | store => \$force }, |
837 | verbose => { default => $conf->get_conf('verbose'), |
838 | store => \$verbose }, |
839 | }; |
840 | |
841 | check( $tmpl, \%hash ) or return; |
842 | |
843 | unless( -d $path ) { |
844 | $self->_mkdir( dir => $path ) |
845 | or( error( loc( "Could not create '%1', giving up", $path ) ), |
846 | return |
847 | ); |
848 | } elsif ( ! -w _ ) { |
849 | error( loc( "Could not write to '%1', giving up", $path ) ); |
850 | return; |
851 | } |
852 | |
853 | my $flag; |
854 | AUTHOR: { |
855 | for my $auth ( sort { $a->cpanid cmp $b->cpanid } |
856 | values %{$self->author_tree} |
857 | ) { |
858 | |
859 | MODULE: { |
860 | my $i; |
861 | for my $mod ( $auth->modules ) { |
862 | my $fetchdir = File::Spec->catdir( $path, $mod->path ); |
863 | |
864 | my %opts = ( |
865 | verbose => $verbose, |
866 | force => $force, |
867 | fetchdir => $fetchdir, |
868 | ); |
869 | |
870 | ### only do this the for the first module ### |
871 | unless( $i++ ) { |
872 | $mod->_get_checksums_file( |
873 | %opts |
874 | ) or ( |
875 | error( loc( "Could not fetch %1 file, " . |
876 | "skipping author '%2'", |
877 | CHECKSUMS, $auth->cpanid ) ), |
878 | $flag++, next AUTHOR |
879 | ); |
880 | } |
881 | |
882 | $mod->fetch( %opts ) |
883 | or( error( loc( "Could not fetch '%1'", $mod->module ) ), |
884 | $flag++, next MODULE |
885 | ); |
886 | } } |
887 | } } |
888 | |
889 | if( $index ) { |
890 | for my $name (qw[auth dslip mod]) { |
891 | $self->_update_source( |
892 | name => $name, |
893 | verbose => $verbose, |
894 | path => $path, |
895 | ) or ( $flag++, next ); |
896 | } |
897 | } |
898 | |
899 | return !$flag; |
900 | } |
901 | |
902 | =pod |
903 | |
904 | =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL]) |
905 | |
906 | Writes out a snapshot of your current installation in C<CPAN> bundle |
907 | style. This can then be used to install the same modules for a |
908 | different or on a different machine. |
909 | |
910 | It will, by default, write to an 'autobundle' directory under your |
911 | cpanplus homedirectory, but you can override that by supplying a |
912 | C<path> argument. |
913 | |
914 | It will return the location of the output file on success and false on |
915 | failure. |
916 | |
917 | =cut |
918 | |
919 | sub autobundle { |
920 | my $self = shift; |
921 | my $conf = $self->configure_object; |
922 | my %hash = @_; |
923 | |
924 | my($path,$force,$verbose); |
925 | my $tmpl = { |
926 | force => { default => $conf->get_conf('force'), store => \$force }, |
927 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
928 | path => { default => File::Spec->catdir( |
929 | $conf->get_conf('base'), |
930 | $self->_perl_version( perl => $^X ), |
931 | $conf->_get_build('distdir'), |
932 | $conf->_get_build('autobundle') ), |
933 | store => \$path }, |
934 | }; |
935 | |
936 | check($tmpl, \%hash) or return; |
937 | |
938 | unless( -d $path ) { |
939 | $self->_mkdir( dir => $path ) |
940 | or( error(loc("Could not create directory '%1'", $path ) ), |
941 | return |
942 | ); |
943 | } |
944 | |
945 | my $name; my $file; |
946 | { ### default filename for the bundle ### |
947 | my($year,$month,$day) = (localtime)[5,4,3]; |
948 | $year += 1900; $month++; |
949 | |
950 | my $ext = 0; |
951 | |
952 | my $prefix = $conf->_get_build('autobundle_prefix'); |
953 | my $format = "${prefix}_%04d_%02d_%02d_%02d"; |
954 | |
955 | BLOCK: { |
956 | $name = sprintf( $format, $year, $month, $day, $ext); |
957 | |
958 | $file = File::Spec->catfile( $path, $name . '.pm' ); |
959 | |
960 | -f $file ? ++$ext && redo BLOCK : last BLOCK; |
961 | } |
962 | } |
963 | my $fh; |
964 | unless( $fh = FileHandle->new( ">$file" ) ) { |
965 | error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); |
966 | return; |
967 | } |
968 | |
969 | my $string = join "\n\n", |
970 | map { |
971 | join ' ', |
972 | $_->module, |
973 | ($_->installed_version(verbose => 0) || 'undef') |
974 | } sort { |
975 | $a->module cmp $b->module |
976 | } $self->installed; |
977 | |
978 | my $now = scalar localtime; |
979 | my $head = '=head1'; |
980 | my $pkg = __PACKAGE__; |
981 | my $version = $self->VERSION; |
982 | my $perl_v = join '', `$^X -V`; |
983 | |
984 | print $fh <<EOF; |
985 | package $name |
986 | |
987 | \$VERSION = '0.01'; |
988 | |
989 | 1; |
990 | |
991 | __END__ |
992 | |
993 | $head NAME |
994 | |
995 | $name - Snapshot of your installation at $now |
996 | |
997 | $head SYNOPSIS |
998 | |
999 | perl -MCPANPLUS -e "install $name" |
1000 | |
1001 | $head CONTENTS |
1002 | |
1003 | $string |
1004 | |
1005 | $head CONFIGURATION |
1006 | |
1007 | $perl_v |
1008 | |
1009 | $head AUTHOR |
1010 | |
1011 | This bundle has been generated autotomatically by |
1012 | $pkg $version |
1013 | |
1014 | EOF |
1015 | |
1016 | close $fh; |
1017 | |
1018 | return $file; |
1019 | } |
1020 | |
1021 | 1; |
1022 | |
1023 | =pod |
1024 | |
1025 | =head1 BUG REPORTS |
1026 | |
1027 | Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. |
1028 | |
1029 | =head1 AUTHOR |
1030 | |
1031 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
1032 | |
1033 | =head1 COPYRIGHT |
1034 | |
1035 | The CPAN++ interface (of which this module is a part of) is copyright (c) |
1036 | 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. |
1037 | |
1038 | This library is free software; you may redistribute and/or modify it |
1039 | under the same terms as Perl itself. |
1040 | |
1041 | =head1 SEE ALSO |
1042 | |
1043 | L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> |
1044 | |
1045 | =cut |
1046 | |
1047 | # Local variables: |
1048 | # c-indentation-style: bsd |
1049 | # c-basic-offset: 4 |
1050 | # indent-tabs-mode: nil |
1051 | # End: |
1052 | # vim: expandtab shiftwidth=4: |
1053 | |
1054 | __END__ |
1055 | |
1056 | todo: |
1057 | sub dist { # not sure about this one -- probably already done |
1058 | enough in Module.pm |
1059 | sub reports { # in Module.pm, wrapper here |
1060 | |
1061 | |