This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
update to CPANPLUS 0.88
[perl5.git] / lib / CPANPLUS / Internals.pm
1 package CPANPLUS::Internals;
2
3 ### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
4 ### and 5.6.0 is just too buggy
5 use 5.006001;
6
7 use strict;
8 use Config;
9
10
11 use CPANPLUS::Error;
12
13 use CPANPLUS::Selfupdate;
14
15 use CPANPLUS::Internals::Extract;
16 use CPANPLUS::Internals::Fetch;
17 use CPANPLUS::Internals::Utils;
18 use CPANPLUS::Internals::Constants;
19 use CPANPLUS::Internals::Search;
20 use CPANPLUS::Internals::Report;
21
22
23 require base;
24 use Cwd                         qw[cwd];
25 use Module::Load                qw[load];
26 use Params::Check               qw[check];
27 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
28 use Module::Load::Conditional   qw[can_load];
29
30 use Object::Accessor;
31
32
33 local $Params::Check::VERBOSE = 1;
34
35 use vars qw[@ISA $VERSION];
36
37 @ISA = qw[
38             CPANPLUS::Internals::Extract
39             CPANPLUS::Internals::Fetch
40             CPANPLUS::Internals::Utils
41             CPANPLUS::Internals::Search
42             CPANPLUS::Internals::Report
43         ];
44
45 $VERSION = "0.88";
46
47 =pod
48
49 =head1 NAME
50
51 CPANPLUS::Internals
52
53 =head1 SYNOPSIS
54
55     my $internals   = CPANPLUS::Internals->_init( _conf => $conf );
56     my $backend     = CPANPLUS::Internals->_retrieve_id( $ID );
57
58 =head1 DESCRIPTION
59
60 This module is the guts of CPANPLUS -- it inherits from all other
61 modules in the CPANPLUS::Internals::* namespace, thus defying normal
62 rules of OO programming -- but if you're reading this, you already
63 know what's going on ;)
64
65 Please read the C<CPANPLUS::Backend> documentation for the normal API.
66
67 =head1 ACCESSORS
68
69 =over 4
70
71 =item _conf
72
73 Get/set the configure object
74
75 =item _id
76
77 Get/set the id
78
79 =cut
80
81 ### autogenerate accessors ###
82 for my $key ( qw[_conf _id _modules _hosts _methods _status
83                  _callbacks _selfupdate _mtree _atree]
84 ) {
85     no strict 'refs';
86     *{__PACKAGE__."::$key"} = sub {
87         $_[0]->{$key} = $_[1] if @_ > 1;
88         return $_[0]->{$key};
89     }
90 }
91
92 =pod
93
94 =back
95
96 =head1 METHODS
97
98 =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
99
100 C<_init> creates a new CPANPLUS::Internals object.
101
102 You have to pass it a valid C<CPANPLUS::Configure> object.
103
104 Returns the object on success, or dies on failure.
105
106 =cut
107 {   ### NOTE:
108     ### if extra callbacks are added, don't forget to update the
109     ### 02-internals.t test script with them!
110     my $callback_map = {
111         ### name                default value    
112         install_prerequisite    => 1,   # install prereqs when 'ask' is set?
113         edit_test_report        => 0,   # edit the prepared test report?
114         send_test_report        => 1,   # send the test report?
115                                         # munge the test report
116         munge_test_report       => sub { return $_[1] },
117                                         # filter out unwanted prereqs
118         filter_prereqs          => sub { return $_[1] },
119                                         # continue if 'make test' fails?
120         proceed_on_test_failure => sub { return 0 },
121         munge_dist_metafile     => sub { return $_[1] },
122     };
123     
124     my $status = Object::Accessor->new;
125     $status->mk_accessors(qw[pending_prereqs]);
126
127     my $callback = Object::Accessor->new;
128     $callback->mk_accessors(keys %$callback_map);
129
130     my $conf;
131     my $Tmpl = {
132         _conf       => { required => 1, store => \$conf,
133                             allow => IS_CONFOBJ },
134         _id         => { default => '',                 no_override => 1 },
135         _authortree => { default => '',                 no_override => 1 },
136         _modtree    => { default => '',                 no_override => 1 },
137         _hosts      => { default => {},                 no_override => 1 },
138         _methods    => { default => {},                 no_override => 1 },
139         _status     => { default => '<empty>',          no_override => 1 },
140         _callbacks  => { default => '<empty>',          no_override => 1 },
141     };
142
143     sub _init {
144         my $class   = shift;
145         my %hash    = @_;
146
147         ### temporary warning until we fix the storing of multiple id's
148         ### and their serialization:
149         ### probably not going to happen --kane
150         if( my $id = $class->_last_id ) {
151             # make it a singleton.
152             warn loc(q[%1 currently only supports one %2 object per ] .
153                      qq[running program\n], 'CPANPLUS', $class);
154
155             return $class->_retrieve_id( $id );
156         }
157
158         my $args = check($Tmpl, \%hash)
159                     or die loc(qq[Could not initialize '%1' object], $class);
160
161         bless $args, $class;
162
163         $args->{'_id'}          = $args->_inc_id;
164         $args->{'_status'}      = $status;
165         $args->{'_callbacks'}   = $callback;
166
167         ### initialize callbacks to default state ###
168         for my $name ( $callback->ls_accessors ) {
169             my $rv = ref $callback_map->{$name} ? 'sub return value' :
170                          $callback_map->{$name} ? 'true' : 'false';
171         
172             $args->_callbacks->$name(
173                 sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
174                               $name, $rv), $args->_conf->get_conf('debug')); 
175                       return ref $callback_map->{$name} 
176                                 ? $callback_map->{$name}->( @_ )
177                                 : $callback_map->{$name};
178                 } 
179             );
180         }
181
182         ### create a selfupdate object
183         $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
184
185         ### initalize it as an empty hashref ###
186         $args->_status->pending_prereqs( {} );
187
188         $conf->_set_build( startdir => cwd() ),
189             or error( loc("couldn't locate current dir!") );
190
191         $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
192
193         my $id = $args->_store_id( $args );
194
195         unless ( $id == $args->_id ) {
196             error( loc("IDs do not match: %1 != %2. Storage failed!",
197                         $id, $args->_id) );
198         }
199
200         ### different source engines available now, so set them here
201         {   my $store = $conf->get_conf( 'source_engine' ) 
202                             || DEFAULT_SOURCE_ENGINE;
203
204             unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
205                 error( loc( "Could not load source engine '%1'", $store ) );
206             
207                 if( $store ne DEFAULT_SOURCE_ENGINE ) {
208                     msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
209                    
210                     load DEFAULT_SOURCE_ENGINE;
211                     
212                     base->import( DEFAULT_SOURCE_ENGINE );
213                 } else {
214                     return;
215                 }     
216             } else {
217                  base->import( $store );
218             }                
219         }
220
221         return $args;
222     }
223
224 =pod
225
226 =head2 $bool = $internals->_flush( list => \@caches )
227
228 Flushes the designated caches from the C<CPANPLUS> object.
229
230 Returns true on success, false if one or more caches could not be
231 be flushed.
232
233 =cut
234
235     sub _flush {
236         my $self = shift;
237         my $conf = $self->configure_object;
238         my %hash = @_;
239
240         my $aref;
241         my $tmpl = {
242             list    => { required => 1, default => [],
243                             strict_type => 1, store => \$aref },
244         };
245
246         my $args = check( $tmpl, \%hash ) or return;
247
248         my $flag = 0;
249         for my $what (@$aref) {
250             my $cache = '_' . $what;
251
252             ### set the include paths back to their original ###
253             if( $what eq 'lib' ) {
254                 $ENV{PERL5LIB}  = $conf->_perl5lib || '';
255                 @INC            = @{$conf->_lib};
256
257             ### give all modules a new status object -- this is slightly
258             ### costly, but the best way to make sure all statusses are
259             ### forgotten --kane
260             } elsif ( $what eq 'modules' ) {
261                 for my $modobj ( values %{$self->module_tree} ) {
262
263                     $modobj->_flush;
264                 }
265
266             ### blow away the methods cache... currently, that's only
267             ### File::Fetch's method fail list
268             } elsif ( $what eq 'methods' ) {
269
270                 ### still fucking p4 :( ###
271                 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
272
273             ### blow away the m::l::c cache, so modules can be (re)loaded
274             ### again if they become available
275             } elsif ( $what eq 'load' ) {
276                 undef $Module::Load::Conditional::CACHE;
277
278             } else {
279                 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
280                     error( loc( "No such cache: '%1'", $what ) );
281                     $flag++;
282                     next;
283                 } else {
284                     $self->$cache( {} );
285                 }
286             }
287         }
288         return !$flag;
289     }
290
291 ### NOTE:
292 ### if extra callbacks are added, don't forget to update the
293 ### 02-internals.t test script with them!
294
295 =pod 
296
297 =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
298
299 Registers a callback for later use by the internal libraries.
300
301 Here is a list of the currently used callbacks:
302
303 =over 4
304
305 =item install_prerequisite
306
307 Is called when the user wants to be C<asked> about what to do with
308 prerequisites. Should return a boolean indicating true to install
309 the prerequisite and false to skip it.
310
311 =item send_test_report
312
313 Is called when the user should be prompted if he wishes to send the
314 test report. Should return a boolean indicating true to send the 
315 test report and false to skip it.
316
317 =item munge_test_report
318
319 Is called when the test report message has been composed, giving
320 the user a chance to programatically alter it. Should return the 
321 (munged) message to be sent.
322
323 =item edit_test_report
324
325 Is called when the user should be prompted to edit test reports
326 about to be sent out by Test::Reporter. Should return a boolean 
327 indicating true to edit the test report in an editor and false 
328 to skip it.
329
330 =item proceed_on_test_failure
331
332 Is called when 'make test' or 'Build test' fails. Should return
333 a boolean indicating whether the install should continue even if
334 the test failed.
335
336 =item munge_dist_metafile
337
338 Is called when the C<CPANPLUS::Dist::*> metafile is created, like
339 C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
340 programatically alter it. Should return the (munged) text to be
341 written to the metafile.
342
343 =back
344
345 =cut
346
347     sub _register_callback {
348         my $self = shift or return;
349         my %hash = @_;
350
351         my ($name,$code);
352         my $tmpl = {
353             name    => { required => 1, store => \$name,
354                          allow => [$callback->ls_accessors] },
355             code    => { required => 1, allow => IS_CODEREF,
356                          store => \$code },
357         };
358
359         check( $tmpl, \%hash ) or return;
360
361         $self->_callbacks->$name( $code ) or return;
362
363         return 1;
364     }
365
366 # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
367
368 # Adds a new callback to be used from anywhere in the system. If the callback
369 # is already known, an error is raised and false is returned. If the callback
370 # is not yet known, it is added, and the corresponding coderef is registered
371 # using the
372
373 # =cut
374
375 #     sub _add_callback {
376 #         my $self = shift or return;
377 #         my %hash = @_;
378 #         
379 #         my ($name,$code);
380 #         my $tmpl = {
381 #             name    => { required => 1, store => \$name, },
382 #             code    => { required => 1, allow => IS_CODEREF,
383 #                          store => \$code },
384 #         };
385
386 #         check( $tmpl, \%hash ) or return;
387
388 #         if( $callback->can( $name ) ) {
389 #             error(loc("Callback '%1' is already registered"));
390 #             return;
391 #         }
392
393 #         $callback->mk_accessor( $name );
394
395 #         $self->_register_callback( name => $name, code => $code ) or return;
396
397 #         return 1;
398 #     }
399
400 }
401
402 =pod
403
404 =head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
405
406 Adds a list of directories to the include path.
407 This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
408
409 Returns true on success, false on failure.
410
411 =cut
412
413 sub _add_to_includepath {
414     my $self = shift;
415     my %hash = @_;
416
417     my $dirs;
418     my $tmpl = {
419         directories => { required => 1, default => [], store => \$dirs,
420                          strict_type => 1 },
421     };
422
423     check( $tmpl, \%hash ) or return;
424
425     my $s = $Config{'path_sep'};
426     
427     ### only add if it's not added yet
428     for my $lib (@$dirs) {
429         push @INC, $lib unless grep { $_ eq $lib } @INC;
430         #
431         ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).   
432         local $^W;  
433         $ENV{'PERL5LIB'} .= $s . $lib 
434             unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
435     }
436
437     return 1;
438 }
439
440 =pod
441
442 =head2 $id = CPANPLUS::Internals->_last_id
443
444 Return the id of the last object stored.
445
446 =head2 $id = CPANPLUS::Internals->_store_id( $internals )
447
448 Store this object; return its id.
449
450 =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
451
452 Retrieve an object based on its ID -- return false on error.
453
454 =head2 CPANPLUS::Internals->_remove_id( $ID )
455
456 Remove the object marked by $ID from storage.
457
458 =head2 @objs = CPANPLUS::Internals->_return_all_objects
459
460 Return all stored objects.
461
462 =cut
463
464
465 ### code for storing multiple objects
466 ### -- although we only support one right now
467 ### XXX when support for multiple objects comes, saving source will have
468 ### to change
469 {
470     my $idref = {};
471     my $count = 0;
472
473     sub _inc_id { return ++$count; }
474
475     sub _last_id { $count }
476
477     sub _store_id {
478         my $self    = shift;
479         my $obj     = shift or return;
480
481        unless( IS_INTERNALS_OBJ->($obj) ) {
482             error( loc("The object you passed has the wrong ref type: '%1'",
483                         ref $obj) );
484             return;
485         }
486
487         $idref->{ $obj->_id } = $obj;
488         return $obj->_id;
489     }
490
491     sub _retrieve_id {
492         my $self    = shift;
493         my $id      = shift or return;
494
495         my $obj = $idref->{$id};
496         return $obj;
497     }
498
499     sub _remove_id {
500         my $self    = shift;
501         my $id      = shift or return;
502
503         return delete $idref->{$id};
504     }
505
506     sub _return_all_objects { return values %$idref }
507 }
508
509 1;
510
511 # Local variables:
512 # c-indentation-style: bsd
513 # c-basic-offset: 4
514 # indent-tabs-mode: nil
515 # End:
516 # vim: expandtab shiftwidth=4: