1 package CPANPLUS::Internals;
3 ### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
4 ### and 5.6.0 is just too buggy
13 use CPANPLUS::Selfupdate;
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;
24 use Params::Check qw[check];
25 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
30 local $Params::Check::VERBOSE = 1;
32 use vars qw[@ISA $VERSION];
35 CPANPLUS::Internals::Source
36 CPANPLUS::Internals::Extract
37 CPANPLUS::Internals::Fetch
38 CPANPLUS::Internals::Utils
39 CPANPLUS::Internals::Search
40 CPANPLUS::Internals::Report
53 my $internals = CPANPLUS::Internals->_init( _conf => $conf );
54 my $backend = CPANPLUS::Internals->_retrieve_id( $ID );
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 ;)
63 Please read the C<CPANPLUS::Backend> documentation for the normal API.
71 Get/set the configure object
79 Get/set the current @INC path -- @INC is reset to this after each
84 Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB}
85 is reset to this after each install.
89 ### autogenerate accessors ###
90 for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status
91 _callbacks _selfupdate]
94 *{__PACKAGE__."::$key"} = sub {
95 $_[0]->{$key} = $_[1] if @_ > 1;
106 =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
108 C<_init> creates a new CPANPLUS::Internals object.
110 You have to pass it a valid C<CPANPLUS::Configure> object.
112 Returns the object on success, or dies on failure.
116 ### if extra callbacks are added, don't forget to update the
117 ### 02-internals.t test script with them!
119 ### name default value
120 install_prerequisite => 1, # install prereqs when 'ask' is set?
121 edit_test_report => 0, # edit the prepared test report?
122 send_test_report => 1, # send the test report?
123 # munge the test report
124 munge_test_report => sub { return $_[1] },
125 # filter out unwanted prereqs
126 filter_prereqs => sub { return $_[1] },
127 # continue if 'make test' fails?
128 proceed_on_test_failure => sub { return 0 },
129 munge_dist_metafile => sub { return $_[1] },
132 my $status = Object::Accessor->new;
133 $status->mk_accessors(qw[pending_prereqs]);
135 my $callback = Object::Accessor->new;
136 $callback->mk_accessors(keys %$callback_map);
140 _conf => { required => 1, store => \$conf,
141 allow => IS_CONFOBJ },
142 _id => { default => '', no_override => 1 },
143 _lib => { default => [ @INC ], no_override => 1 },
144 _perl5lib => { default => $ENV{'PERL5LIB'}, no_override => 1 },
145 _authortree => { default => '', no_override => 1 },
146 _modtree => { default => '', no_override => 1 },
147 _hosts => { default => {}, no_override => 1 },
148 _methods => { default => {}, no_override => 1 },
149 _status => { default => '<empty>', no_override => 1 },
150 _callbacks => { default => '<empty>', no_override => 1 },
157 ### temporary warning until we fix the storing of multiple id's
158 ### and their serialization:
159 ### probably not going to happen --kane
160 if( my $id = $class->_last_id ) {
161 # make it a singleton.
162 warn loc(q[%1 currently only supports one %2 object per ] .
163 q[running program], 'CPANPLUS', $class);
165 return $class->_retrieve_id( $id );
168 my $args = check($Tmpl, \%hash)
169 or die loc(qq[Could not initialize '%1' object], $class);
173 $args->{'_id'} = $args->_inc_id;
174 $args->{'_status'} = $status;
175 $args->{'_callbacks'} = $callback;
177 ### initialize callbacks to default state ###
178 for my $name ( $callback->ls_accessors ) {
179 my $rv = ref $callback_map->{$name} ? 'sub return value' :
180 $callback_map->{$name} ? 'true' : 'false';
182 $args->_callbacks->$name(
183 sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
184 $name, $rv), $args->_conf->get_conf('debug'));
185 return ref $callback_map->{$name}
186 ? $callback_map->{$name}->( @_ )
187 : $callback_map->{$name};
192 ### create a selfupdate object
193 $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
195 ### initalize it as an empty hashref ###
196 $args->_status->pending_prereqs( {} );
198 ### allow for dirs to be added to @INC at runtime,
199 ### rather then compile time
200 push @INC, @{$conf->get_conf('lib')};
202 ### add any possible new dirs ###
203 $args->_lib( [@INC] );
205 $conf->_set_build( startdir => cwd() ),
206 or error( loc("couldn't locate current dir!") );
208 $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
210 my $id = $args->_store_id( $args );
212 unless ( $id == $args->_id ) {
213 error( loc("IDs do not match: %1 != %2. Storage failed!",
222 =head2 $bool = $internals->_flush( list => \@caches )
224 Flushes the designated caches from the C<CPANPLUS> object.
226 Returns true on success, false if one or more caches could not be
237 list => { required => 1, default => [],
238 strict_type => 1, store => \$aref },
241 my $args = check( $tmpl, \%hash ) or return;
244 for my $what (@$aref) {
245 my $cache = '_' . $what;
247 ### set the include paths back to their original ###
248 if( $what eq 'lib' ) {
249 $ENV{PERL5LIB} = $self->_perl5lib || '';
250 @INC = @{$self->_lib};
252 ### give all modules a new status object -- this is slightly
253 ### costly, but the best way to make sure all statusses are
255 } elsif ( $what eq 'modules' ) {
256 for my $modobj ( values %{$self->module_tree} ) {
260 ### blow away the methods cache... currently, that's only
261 ### File::Fetch's method fail list
262 } elsif ( $what eq 'methods' ) {
264 ### still fucking p4 :( ###
265 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
267 ### blow away the m::l::c cache, so modules can be (re)loaded
268 ### again if they become available
269 } elsif ( $what eq 'load' ) {
270 undef $Module::Load::Conditional::CACHE;
273 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
274 error( loc( "No such cache: '%1'", $what ) );
286 ### if extra callbacks are added, don't forget to update the
287 ### 02-internals.t test script with them!
291 =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
293 Registers a callback for later use by the internal libraries.
295 Here is a list of the currently used callbacks:
299 =item install_prerequisite
301 Is called when the user wants to be C<asked> about what to do with
302 prerequisites. Should return a boolean indicating true to install
303 the prerequisite and false to skip it.
305 =item send_test_report
307 Is called when the user should be prompted if he wishes to send the
308 test report. Should return a boolean indicating true to send the
309 test report and false to skip it.
311 =item munge_test_report
313 Is called when the test report message has been composed, giving
314 the user a chance to programatically alter it. Should return the
315 (munged) message to be sent.
317 =item edit_test_report
319 Is called when the user should be prompted to edit test reports
320 about to be sent out by Test::Reporter. Should return a boolean
321 indicating true to edit the test report in an editor and false
324 =item proceed_on_test_failure
326 Is called when 'make test' or 'Build test' fails. Should return
327 a boolean indicating whether the install should continue even if
330 =item munge_dist_metafile
332 Is called when the C<CPANPLUS::Dist::*> metafile is created, like
333 C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
334 programatically alter it. Should return the (munged) text to be
335 written to the metafile.
341 sub _register_callback {
342 my $self = shift or return;
347 name => { required => 1, store => \$name,
348 allow => [$callback->ls_accessors] },
349 code => { required => 1, allow => IS_CODEREF,
353 check( $tmpl, \%hash ) or return;
355 $self->_callbacks->$name( $code ) or return;
360 # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
362 # Adds a new callback to be used from anywhere in the system. If the callback
363 # is already known, an error is raised and false is returned. If the callback
364 # is not yet known, it is added, and the corresponding coderef is registered
369 # sub _add_callback {
370 # my $self = shift or return;
375 # name => { required => 1, store => \$name, },
376 # code => { required => 1, allow => IS_CODEREF,
380 # check( $tmpl, \%hash ) or return;
382 # if( $callback->can( $name ) ) {
383 # error(loc("Callback '%1' is already registered"));
387 # $callback->mk_accessor( $name );
389 # $self->_register_callback( name => $name, code => $code ) or return;
398 =head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
400 Adds a list of directories to the include path.
401 This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
403 Returns true on success, false on failure.
407 sub _add_to_includepath {
413 directories => { required => 1, default => [], store => \$dirs,
417 check( $tmpl, \%hash ) or return;
419 for my $lib (@$dirs) {
420 push @INC, $lib unless grep { $_ eq $lib } @INC;
423 { local $^W; ### it will be complaining if $ENV{PERL5LIB]
424 ### is not defined (yet).
425 $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs;
433 =head2 $id = CPANPLUS::Internals->_last_id
435 Return the id of the last object stored.
437 =head2 $id = CPANPLUS::Internals->_store_id( $internals )
439 Store this object; return its id.
441 =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
443 Retrieve an object based on its ID -- return false on error.
445 =head2 CPANPLUS::Internals->_remove_id( $ID )
447 Remove the object marked by $ID from storage.
449 =head2 @objs = CPANPLUS::Internals->_return_all_objects
451 Return all stored objects.
456 ### code for storing multiple objects
457 ### -- although we only support one right now
458 ### XXX when support for multiple objects comes, saving source will have
464 sub _inc_id { return ++$count; }
466 sub _last_id { $count }
470 my $obj = shift or return;
472 unless( IS_INTERNALS_OBJ->($obj) ) {
473 error( loc("The object you passed has the wrong ref type: '%1'",
478 $idref->{ $obj->_id } = $obj;
484 my $id = shift or return;
486 my $obj = $idref->{$id};
492 my $id = shift or return;
494 return delete $idref->{$id};
497 sub _return_all_objects { return values %$idref }
503 # c-indentation-style: bsd
505 # indent-tabs-mode: nil
507 # vim: expandtab shiftwidth=4: