This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
37b8596cde482598fce12657d3efa9f5082ced2c
[perl5.git] / cpan / CPANPLUS / 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.9130";
46
47 =pod
48
49 =head1 NAME
50
51 CPANPLUS::Internals - 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 _path
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
108 {   ### NOTE:
109     ### if extra callbacks are added, don't forget to update the
110     ### 02-internals.t test script with them!
111     my $callback_map = {
112         ### name                default value
113         install_prerequisite    => 1,   # install prereqs when 'ask' is set?
114         edit_test_report        => 0,   # edit the prepared test report?
115         send_test_report        => 1,   # send the test report?
116                                         # munge the test report
117         munge_test_report       => sub { return $_[1] },
118                                         # filter out unwanted prereqs
119         filter_prereqs          => sub { return $_[1] },
120                                         # continue if 'make test' fails?
121         proceed_on_test_failure => sub { return 0 },
122         munge_dist_metafile     => sub { return $_[1] },
123     };
124
125     my $status = Object::Accessor->new;
126     $status->mk_accessors(qw[pending_prereqs]);
127
128     my $callback = Object::Accessor->new;
129     $callback->mk_accessors(keys %$callback_map);
130
131     my $conf;
132     my $Tmpl = {
133         _conf       => { required => 1, store => \$conf,
134                             allow => IS_CONFOBJ },
135         _id         => { default => '',                 no_override => 1 },
136         _authortree => { default => '',                 no_override => 1 },
137         _modtree    => { default => '',                 no_override => 1 },
138         _hosts      => { default => {},                 no_override => 1 },
139         _methods    => { default => {},                 no_override => 1 },
140         _status     => { default => '<empty>',          no_override => 1 },
141         _callbacks  => { default => '<empty>',          no_override => 1 },
142         _path       => { default => $ENV{PATH} || '',   no_override => 1 },
143     };
144
145     sub _init {
146         my $class   = shift;
147         my %hash    = @_;
148
149         ### temporary warning until we fix the storing of multiple id's
150         ### and their serialization:
151         ### probably not going to happen --kane
152         if( my $id = $class->_last_id ) {
153             # make it a singleton.
154             warn loc(q[%1 currently only supports one %2 object per ] .
155                      qq[running program\n], 'CPANPLUS', $class);
156
157             return $class->_retrieve_id( $id );
158         }
159
160         my $args = check($Tmpl, \%hash)
161                     or die loc(qq[Could not initialize '%1' object], $class);
162
163         bless $args, $class;
164
165         $args->{'_id'}          = $args->_inc_id;
166         $args->{'_status'}      = $status;
167         $args->{'_callbacks'}   = $callback;
168
169         ### initialize callbacks to default state ###
170         for my $name ( $callback->ls_accessors ) {
171             my $rv = ref $callback_map->{$name} ? 'sub return value' :
172                          $callback_map->{$name} ? 'true' : 'false';
173
174             $args->_callbacks->$name(
175                 sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
176                               $name, $rv), $args->_conf->get_conf('debug'));
177                       return ref $callback_map->{$name}
178                                 ? $callback_map->{$name}->( @_ )
179                                 : $callback_map->{$name};
180                 }
181             );
182         }
183
184         ### create a selfupdate object
185         $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
186
187         ### initialize it as an empty hashref ###
188         $args->_status->pending_prereqs( {} );
189
190         $conf->_set_build( startdir => cwd() ),
191             or error( loc("couldn't locate current dir!") );
192
193         $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
194
195         my $id = $args->_store_id( $args );
196
197         unless ( $id == $args->_id ) {
198             error( loc("IDs do not match: %1 != %2. Storage failed!",
199                         $id, $args->_id) );
200         }
201
202         ### different source engines available now, so set them here
203         {   my $store = $conf->get_conf( 'source_engine' )
204                             || DEFAULT_SOURCE_ENGINE;
205
206             unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
207                 error( loc( "Could not load source engine '%1'", $store ) );
208
209                 if( $store ne DEFAULT_SOURCE_ENGINE ) {
210                     msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
211
212                     load DEFAULT_SOURCE_ENGINE;
213
214                     base->import( DEFAULT_SOURCE_ENGINE );
215                 } else {
216                     return;
217                 }
218             } else {
219                  base->import( $store );
220             }
221         }
222
223         return $args;
224     }
225
226 =pod
227
228 =head2 $bool = $internals->_flush( list => \@caches )
229
230 Flushes the designated caches from the C<CPANPLUS> object.
231
232 Returns true on success, false if one or more caches could not be
233 be flushed.
234
235 =cut
236
237     sub _flush {
238         my $self = shift;
239         my $conf = $self->configure_object;
240         my %hash = @_;
241
242         my $aref;
243         my $tmpl = {
244             list    => { required => 1, default => [],
245                             strict_type => 1, store => \$aref },
246         };
247
248         my $args = check( $tmpl, \%hash ) or return;
249
250         my $flag = 0;
251         for my $what (@$aref) {
252             my $cache = '_' . $what;
253
254             ### set the include paths back to their original ###
255             if( $what eq 'lib' ) {
256                 $ENV{PERL5LIB}  = $conf->_perl5lib || '';
257                 @INC            = @{$conf->_lib};
258                 $ENV{PATH}      = $self->_path || '';
259
260             ### give all modules a new status object -- this is slightly
261             ### costly, but the best way to make sure all statuses are
262             ### forgotten --kane
263             } elsif ( $what eq 'modules' ) {
264                 for my $modobj ( values %{$self->module_tree} ) {
265
266                     $modobj->_flush;
267                 }
268
269             ### blow away the methods cache... currently, that's only
270             ### File::Fetch's method fail list
271             } elsif ( $what eq 'methods' ) {
272
273                 ### still unbelievably p4 :( ###
274                 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
275
276             ### blow away the m::l::c cache, so modules can be (re)loaded
277             ### again if they become available
278             } elsif ( $what eq 'load' ) {
279                 undef $Module::Load::Conditional::CACHE;
280
281             } else {
282                 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
283                     error( loc( "No such cache: '%1'", $what ) );
284                     $flag++;
285                     next;
286                 } else {
287                     $self->$cache( {} );
288                 }
289             }
290         }
291         return !$flag;
292     }
293
294 ### NOTE:
295 ### if extra callbacks are added, don't forget to update the
296 ### 02-internals.t test script with them!
297
298 =pod
299
300 =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
301
302 Registers a callback for later use by the internal libraries.
303
304 Here is a list of the currently used callbacks:
305
306 =over 4
307
308 =item install_prerequisite
309
310 Is called when the user wants to be C<asked> about what to do with
311 prerequisites. Should return a boolean indicating true to install
312 the prerequisite and false to skip it.
313
314 =item send_test_report
315
316 Is called when the user should be prompted if he wishes to send the
317 test report. Should return a boolean indicating true to send the
318 test report and false to skip it.
319
320 =item munge_test_report
321
322 Is called when the test report message has been composed, giving
323 the user a chance to programatically alter it. Should return the
324 (munged) message to be sent.
325
326 =item edit_test_report
327
328 Is called when the user should be prompted to edit test reports
329 about to be sent out by Test::Reporter. Should return a boolean
330 indicating true to edit the test report in an editor and false
331 to skip it.
332
333 =item proceed_on_test_failure
334
335 Is called when 'make test' or 'Build test' fails. Should return
336 a boolean indicating whether the install should continue even if
337 the test failed.
338
339 =item munge_dist_metafile
340
341 Is called when the C<CPANPLUS::Dist::*> metafile is created, like
342 C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
343 programatically alter it. Should return the (munged) text to be
344 written to the metafile.
345
346 =back
347
348 =cut
349
350     sub _register_callback {
351         my $self = shift or return;
352         my %hash = @_;
353
354         my ($name,$code);
355         my $tmpl = {
356             name    => { required => 1, store => \$name,
357                          allow => [$callback->ls_accessors] },
358             code    => { required => 1, allow => IS_CODEREF,
359                          store => \$code },
360         };
361
362         check( $tmpl, \%hash ) or return;
363
364         $self->_callbacks->$name( $code ) or return;
365
366         return 1;
367     }
368
369 # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
370 #
371 # Adds a new callback to be used from anywhere in the system. If the callback
372 # is already known, an error is raised and false is returned. If the callback
373 # is not yet known, it is added, and the corresponding coderef is registered
374 # using the
375 #
376 # =cut
377 #
378 #     sub _add_callback {
379 #         my $self = shift or return;
380 #         my %hash = @_;
381 #
382 #         my ($name,$code);
383 #         my $tmpl = {
384 #             name    => { required => 1, store => \$name, },
385 #             code    => { required => 1, allow => IS_CODEREF,
386 #                          store => \$code },
387 #         };
388 #
389 #         check( $tmpl, \%hash ) or return;
390 #
391 #         if( $callback->can( $name ) ) {
392 #             error(loc("Callback '%1' is already registered"));
393 #             return;
394 #         }
395 #
396 #         $callback->mk_accessor( $name );
397 #
398 #         $self->_register_callback( name => $name, code => $code ) or return;
399 #
400 #         return 1;
401 #     }
402
403 }
404
405 =pod
406
407 =head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
408
409 Adds a list of directories to the include path.
410 This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
411
412 Returns true on success, false on failure.
413
414 =cut
415
416 sub _add_to_includepath {
417     my $self = shift;
418     my %hash = @_;
419
420     my $dirs;
421     my $tmpl = {
422         directories => { required => 1, default => [], store => \$dirs,
423                          strict_type => 1 },
424     };
425
426     check( $tmpl, \%hash ) or return;
427
428     my $s = $Config{'path_sep'};
429
430     ### only add if it's not added yet
431     for my $lib (@$dirs) {
432         push @INC, $lib unless grep { $_ eq $lib } @INC;
433         #
434         ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).
435         local $^W;
436         $ENV{'PERL5LIB'} .= $s . $lib
437             unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
438     }
439
440     return 1;
441 }
442
443 =pod
444
445 =head2 $bool = $internals->_add_to_path( directories => \@dirs )
446
447 Adds a list of directories to the PATH, but only if they actually
448 contain anything.
449
450 Returns true on success, false on failure.
451
452 =cut
453
454 sub _add_to_path {
455     my $self = shift;
456     my %hash = @_;
457
458     my $dirs;
459     my $tmpl = {
460         directories => { required => 1, default => [], store => \$dirs,
461                          strict_type => 1 },
462     };
463
464     check( $tmpl, \%hash ) or return;
465
466     my $s = $Config{'path_sep'};
467
468     require File::Glob;
469
470     ### only add if it's not added yet
471     for my $dir (@$dirs) {
472         $dir =~ s![\\/]*$!!g;
473         next if $ENV{PATH} =~ qr|\Q$dir\E|;
474         next unless -d $dir;
475         next unless File::Glob::bsd_glob( $dir . q{/*} );
476         $ENV{PATH} = join $s, $dir, $ENV{PATH};
477     }
478
479     return 1;
480 }
481
482 =pod
483
484 =head2 $id = CPANPLUS::Internals->_last_id
485
486 Return the id of the last object stored.
487
488 =head2 $id = CPANPLUS::Internals->_store_id( $internals )
489
490 Store this object; return its id.
491
492 =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
493
494 Retrieve an object based on its ID -- return false on error.
495
496 =head2 CPANPLUS::Internals->_remove_id( $ID )
497
498 Remove the object marked by $ID from storage.
499
500 =head2 @objs = CPANPLUS::Internals->_return_all_objects
501
502 Return all stored objects.
503
504 =cut
505
506
507 ### code for storing multiple objects
508 ### -- although we only support one right now
509 ### XXX when support for multiple objects comes, saving source will have
510 ### to change
511 {
512     my $idref = {};
513     my $count = 0;
514
515     sub _inc_id { return ++$count; }
516
517     sub _last_id { $count }
518
519     sub _store_id {
520         my $self    = shift;
521         my $obj     = shift or return;
522
523        unless( IS_INTERNALS_OBJ->($obj) ) {
524             error( loc("The object you passed has the wrong ref type: '%1'",
525                         ref $obj) );
526             return;
527         }
528
529         $idref->{ $obj->_id } = $obj;
530         return $obj->_id;
531     }
532
533     sub _retrieve_id {
534         my $self    = shift;
535         my $id      = shift or return;
536
537         my $obj = $idref->{$id};
538         return $obj;
539     }
540
541     sub _remove_id {
542         my $self    = shift;
543         my $id      = shift or return;
544
545         return delete $idref->{$id};
546     }
547
548     sub _return_all_objects { return values %$idref }
549 }
550
551 1;
552
553 # Local variables:
554 # c-indentation-style: bsd
555 # c-basic-offset: 4
556 # indent-tabs-mode: nil
557 # End:
558 # vim: expandtab shiftwidth=4: