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