File Coverage

lib/CPANPLUS/Internals.pm
Criterion Covered Total %
statement 152 166 91.5
branch 43 62 69.3
condition 4 9 44.4
subroutine 32 32 100.0
pod n/a
total 231 269 85.8


line stmt bran cond sub pod time code
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 20     20   479 use 5.006001;
  20         71  
6              
7 20     20   131 use strict;
  20         36  
  20         757  
8 20     20   172 use Config;
  20         34  
  20         915  
9              
10 20     20   130 use CPANPLUS::Error;
  20         35  
  20         1209  
11              
12 20     20   7258 use CPANPLUS::Selfupdate;
  20         63  
  20         762  
13              
14 20     20   8058 use CPANPLUS::Internals::Extract;
  20         87  
  20         798  
15 20     20   8832 use CPANPLUS::Internals::Fetch;
  20         69  
  20         861  
16 20     20   160 use CPANPLUS::Internals::Utils;
  20         54  
  20         561  
17 20     20   141 use CPANPLUS::Internals::Constants;
  20         45  
  20         6686  
18 20     20   8385 use CPANPLUS::Internals::Search;
  20         62  
  20         662  
19 20     20   7693 use CPANPLUS::Internals::Report;
  20         1488  
  20         1073  
20              
21             require base;
22 20     20   143 use Cwd qw[cwd];
  20         39  
  20         1018  
23 20     20   122 use Module::Load qw[load];
  20         40  
  20         192  
24 20     20   1444 use Params::Check qw[check];
  20         52  
  20         849  
25 20     20   116 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  20         46  
  20         75  
26 20     20   5297 use Module::Load::Conditional qw[can_load];
  20         41  
  20         941  
27              
28 20     20   119 use Object::Accessor;
  20         40  
  20         696  
29              
30             local $Params::Check::VERBOSE = 1;
31              
32 20     20   105 use vars qw[@ISA $VERSION];
  20         55  
  20         1593  
33              
34             @ISA = qw[
35             CPANPLUS::Internals::Extract
36             CPANPLUS::Internals::Fetch
37             CPANPLUS::Internals::Utils
38             CPANPLUS::Internals::Search
39             CPANPLUS::Internals::Report
40             ];
41              
42             $VERSION = "0.9910";
43              
44             =pod
45              
46             =head1 NAME
47              
48             CPANPLUS::Internals - CPANPLUS internals
49              
50             =head1 SYNOPSIS
51              
52             my $internals = CPANPLUS::Internals->_init( _conf => $conf );
53             my $backend = CPANPLUS::Internals->_retrieve_id( $ID );
54              
55             =head1 DESCRIPTION
56              
57             This module is the guts of CPANPLUS -- it inherits from all other
58             modules in the CPANPLUS::Internals::* namespace, thus defying normal
59             rules of OO programming -- but if you're reading this, you already
60             know what's going on ;)
61              
62             Please read the C documentation for the normal API.
63              
64             =head1 ACCESSORS
65              
66             =over 4
67              
68             =item _conf
69              
70             Get/set the configure object
71              
72             =item _id
73              
74             Get/set the id
75              
76             =cut
77              
78             ### autogenerate accessors ###
79             for my $key ( qw[_conf _id _modules _hosts _methods _status _path
80             _callbacks _selfupdate _mtree _atree]
81             ) {
82 20     20   117 no strict 'refs';
  20         42  
  20         38648  
83             *{__PACKAGE__."::$key"} = sub {
84 9643 100   9643   36668 $_[0]->{$key} = $_[1] if @_ > 1;
85 9643         44115 return $_[0]->{$key};
86             }
87             }
88              
89             =pod
90              
91             =back
92              
93             =head1 METHODS
94              
95             =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
96              
97             C<_init> creates a new CPANPLUS::Internals object.
98              
99             You have to pass it a valid C object.
100              
101             Returns the object on success, or dies on failure.
102              
103             =cut
104              
105             { ### NOTE:
106             ### if extra callbacks are added, don't forget to update the
107             ### 02-internals.t test script with them!
108             my $callback_map = {
109             ### name default value
110             install_prerequisite => 1, # install prereqs when 'ask' is set?
111             edit_test_report => 0, # edit the prepared test report?
112             send_test_report => 1, # send the test report?
113             # munge the test report
114             munge_test_report => sub { return $_[1] },
115             # filter out unwanted prereqs
116             filter_prereqs => sub { return $_[1] },
117             # continue if 'make test' fails?
118             proceed_on_test_failure => sub { return 0 },
119             munge_dist_metafile => sub { return $_[1] },
120             };
121              
122             my $status = Object::Accessor->new;
123             $status->mk_accessors(qw[pending_prereqs]);
124              
125             my $callback = Object::Accessor->new;
126             $callback->mk_accessors(keys %$callback_map);
127              
128             my $conf;
129             my $Tmpl = {
130             _conf => { required => 1, store => \$conf,
131             allow => IS_CONFOBJ },
132             _id => { default => '', no_override => 1 },
133             _authortree => { default => '', no_override => 1 },
134             _modtree => { default => '', no_override => 1 },
135             _hosts => { default => {}, no_override => 1 },
136             _methods => { default => {}, no_override => 1 },
137             _status => { default => '', no_override => 1 },
138             _callbacks => { default => '', no_override => 1 },
139             _path => { default => $ENV{PATH} || '', no_override => 1 },
140             };
141              
142             sub _init {
143 14     14   47 my $class = shift;
144 14         70 my %hash = @_;
145              
146             ### temporary warning until we fix the storing of multiple id's
147             ### and their serialization:
148             ### probably not going to happen --kane
149 14 50       102 if( my $id = $class->_last_id ) {
150             # make it a singleton.
151 0         0 warn loc(q[%1 currently only supports one %2 object per ] .
152             qq[running program\n], 'CPANPLUS', $class);
153              
154 0         0 return $class->_retrieve_id( $id );
155             }
156              
157 14 50       97 my $args = check($Tmpl, \%hash)
158             or die loc(qq[Could not initialize '%1' object], $class);
159              
160 14         354 bless $args, $class;
161              
162 14         115 $args->{'_id'} = $args->_inc_id;
163 14         56 $args->{'_status'} = $status;
164 14         42 $args->{'_callbacks'} = $callback;
165              
166             ### initialize callbacks to default state ###
167 14         84 for my $name ( $callback->ls_accessors ) {
168             my $rv = ref $callback_map->{$name} ? 'sub return value' :
169 98 100       8401 $callback_map->{$name} ? 'true' : 'false';
    100          
170              
171             $args->_callbacks->$name(
172 13     13   1358 sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
173             $name, $rv), $args->_conf->get_conf('debug'));
174             return ref $callback_map->{$name}
175             ? $callback_map->{$name}->( @_ )
176 13 100       200 : $callback_map->{$name};
177             }
178 98         283 );
179             }
180              
181             ### create a selfupdate object
182 14         1387 $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
183              
184             ### initialize it as an empty hashref ###
185 14         116 $args->_status->pending_prereqs( {} );
186              
187 14 50       74063 $conf->_set_build( startdir => cwd() ),
188             or error( loc("couldn't locate current dir!") );
189              
190 14 50       452 $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
191              
192 14         736 my $id = $args->_store_id( $args );
193              
194 14 50       183 unless ( $id == $args->_id ) {
195 0         0 error( loc("IDs do not match: %1 != %2. Storage failed!",
196             $id, $args->_id) );
197             }
198              
199             ### different source engines available now, so set them here
200 14   50     103 { my $store = $conf->get_conf( 'source_engine' )
  14         231  
201             || DEFAULT_SOURCE_ENGINE;
202              
203 14 50       576 unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
204 0         0 error( loc( "Could not load source engine '%1'", $store ) );
205              
206 0 0       0 if( $store ne DEFAULT_SOURCE_ENGINE ) {
207 0         0 msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
208              
209 0         0 load DEFAULT_SOURCE_ENGINE;
210              
211 0         0 base->import( DEFAULT_SOURCE_ENGINE );
212             } else {
213 0         0 return;
214             }
215             } else {
216 14         3224 base->import( $store );
217             }
218             }
219              
220 14         337 return $args;
221             }
222              
223             =pod
224              
225             =head2 $bool = $internals->_flush( list => \@caches )
226              
227             Flushes the designated caches from the C object.
228              
229             Returns true on success, false if one or more caches could not be
230             be flushed.
231              
232             =cut
233              
234             sub _flush {
235 9     9   737 my $self = shift;
236 9         50 my $conf = $self->configure_object;
237 9         76 my %hash = @_;
238              
239 9         34 my $aref;
240 9         87 my $tmpl = {
241             list => { required => 1, default => [],
242             strict_type => 1, store => \$aref },
243             };
244              
245 9 50       50 my $args = check( $tmpl, \%hash ) or return;
246              
247 9         797 my $flag = 0;
248 9         43 for my $what (@$aref) {
249 15         38 my $cache = '_' . $what;
250              
251             ### set the include paths back to their original ###
252 15 100       130 if( $what eq 'lib' ) {
    100          
    100          
    100          
253 5   50     58 $ENV{PERL5LIB} = $conf->_perl5lib || '';
254 5         19 @INC = @{$conf->_lib};
  5         36  
255 5   50     52 $ENV{PATH} = $self->_path || '';
256              
257             ### give all modules a new status object -- this is slightly
258             ### costly, but the best way to make sure all statuses are
259             ### forgotten --kane
260             } elsif ( $what eq 'modules' ) {
261 2         4 for my $modobj ( values %{$self->module_tree} ) {
  2         23  
262              
263 20         56 $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 unbelievably p4 :( ###
271 2         21 $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 3         169 undef $Module::Load::Conditional::CACHE;
277              
278             } else {
279 3 50 33     55 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
280 0         0 error( loc( "No such cache: '%1'", $what ) );
281 0         0 $flag++;
282 0         0 next;
283             } else {
284 3         31 $self->$cache( {} );
285             }
286             }
287             }
288 9         94 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 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 programmatically 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 metafile is created, like
339             C for C, giving the user a chance to
340             programmatically 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 9 50   9   239 my $self = shift or return;
349 9         52 my %hash = @_;
350              
351 9         29 my ($name,$code);
352 9         73 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 9 50       323 check( $tmpl, \%hash ) or return;
360              
361 9 50       515 $self->_callbacks->$name( $code ) or return;
362              
363 9         1051 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 12     12   21547 my $self = shift;
415 12         120 my %hash = @_;
416              
417 12         52 my $dirs;
418 12         116 my $tmpl = {
419             directories => { required => 1, default => [], store => \$dirs,
420             strict_type => 1 },
421             };
422              
423 12 50       131 check( $tmpl, \%hash ) or return;
424              
425 12         1542 my $s = $Config{'path_sep'};
426              
427             ### only add if it's not added yet
428 12         119 for my $lib (@$dirs) {
429 32 100       126 unshift @INC, $lib unless grep { $_ eq $lib } @INC;
  504         1192  
430             #
431             ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).
432 32         172 local $^W;
433             $ENV{'PERL5LIB'} .= $s . $lib
434 32 100       1863 unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
435             }
436              
437 12         130 return 1;
438             }
439              
440             =pod
441              
442             =head2 $bool = $internals->_add_to_path( directories => \@dirs )
443              
444             Adds a list of directories to the PATH, but only if they actually
445             contain anything.
446              
447             Returns true on success, false on failure.
448              
449             =cut
450              
451             sub _add_to_path {
452 10     10   48 my $self = shift;
453 10         63 my %hash = @_;
454              
455 10         32 my $dirs;
456 10         82 my $tmpl = {
457             directories => { required => 1, default => [], store => \$dirs,
458             strict_type => 1 },
459             };
460              
461 10 50       67 check( $tmpl, \%hash ) or return;
462              
463 10         898 my $s = $Config{'path_sep'};
464              
465 10         149 require File::Glob;
466              
467             ### only add if it's not added yet
468 10         11883 for my $dir (@$dirs) {
469 20         480 $dir =~ s![\\/]*$!!g;
470 20 100       786 next if $ENV{PATH} =~ qr|\Q$dir\E|;
471 16 100       559 next unless -d $dir;
472 12 100       1292 next unless File::Glob::bsd_glob( $dir . q{/*} );
473 4         110 $ENV{PATH} = join $s, $dir, $ENV{PATH};
474             }
475              
476 10         118 return 1;
477             }
478              
479             =pod
480              
481             =head2 $id = CPANPLUS::Internals->_last_id
482              
483             Return the id of the last object stored.
484              
485             =head2 $id = CPANPLUS::Internals->_store_id( $internals )
486              
487             Store this object; return its id.
488              
489             =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
490              
491             Retrieve an object based on its ID -- return false on error.
492              
493             =head2 CPANPLUS::Internals->_remove_id( $ID )
494              
495             Remove the object marked by $ID from storage.
496              
497             =head2 @objs = CPANPLUS::Internals->_return_all_objects
498              
499             Return all stored objects.
500              
501             =cut
502              
503              
504             ### code for storing multiple objects
505             ### -- although we only support one right now
506             ### XXX when support for multiple objects comes, saving source will have
507             ### to change
508             {
509             my $idref = {};
510             my $count = 0;
511              
512 15     15   1136 sub _inc_id { return ++$count; }
513              
514 278     278   1931 sub _last_id { $count }
515              
516             sub _store_id {
517 15     15   1424 my $self = shift;
518 15 50       277 my $obj = shift or return;
519              
520 15 50       401 unless( IS_INTERNALS_OBJ->($obj) ) {
521 0         0 error( loc("The object you passed has the wrong ref type: '%1'",
522             ref $obj) );
523 0         0 return;
524             }
525              
526 15         458 $idref->{ $obj->_id } = $obj;
527 15         257 return $obj->_id;
528             }
529              
530             sub _retrieve_id {
531 831     831   2263 my $self = shift;
532 831 50       3387 my $id = shift or return;
533              
534 831         2485 my $obj = $idref->{$id};
535 831         2309 return $obj;
536             }
537              
538             sub _remove_id {
539 1     1   5 my $self = shift;
540 1 50       4 my $id = shift or return;
541              
542 1         6 return delete $idref->{$id};
543             }
544              
545 87     87   576 sub _return_all_objects { return values %$idref }
546             }
547              
548             1;
549              
550             # Local variables:
551             # c-indentation-style: bsd
552             # c-basic-offset: 4
553             # indent-tabs-mode: nil
554             # End:
555             # vim: expandtab shiftwidth=4: