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::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;
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];
33 local $Params::Check::VERBOSE = 1;
35 use vars qw[@ISA $VERSION];
38 CPANPLUS::Internals::Extract
39 CPANPLUS::Internals::Fetch
40 CPANPLUS::Internals::Utils
41 CPANPLUS::Internals::Search
42 CPANPLUS::Internals::Report
55 my $internals = CPANPLUS::Internals->_init( _conf => $conf );
56 my $backend = CPANPLUS::Internals->_retrieve_id( $ID );
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 ;)
65 Please read the C<CPANPLUS::Backend> documentation for the normal API.
73 Get/set the configure object
81 ### autogenerate accessors ###
82 for my $key ( qw[_conf _id _modules _hosts _methods _status
83 _callbacks _selfupdate _mtree _atree]
86 *{__PACKAGE__."::$key"} = sub {
87 $_[0]->{$key} = $_[1] if @_ > 1;
98 =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
100 C<_init> creates a new CPANPLUS::Internals object.
102 You have to pass it a valid C<CPANPLUS::Configure> object.
104 Returns the object on success, or dies on failure.
108 ### if extra callbacks are added, don't forget to update the
109 ### 02-internals.t test script with them!
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] },
124 my $status = Object::Accessor->new;
125 $status->mk_accessors(qw[pending_prereqs]);
127 my $callback = Object::Accessor->new;
128 $callback->mk_accessors(keys %$callback_map);
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 },
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);
155 return $class->_retrieve_id( $id );
158 my $args = check($Tmpl, \%hash)
159 or die loc(qq[Could not initialize '%1' object], $class);
163 $args->{'_id'} = $args->_inc_id;
164 $args->{'_status'} = $status;
165 $args->{'_callbacks'} = $callback;
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';
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};
182 ### create a selfupdate object
183 $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
185 ### initalize it as an empty hashref ###
186 $args->_status->pending_prereqs( {} );
188 $conf->_set_build( startdir => cwd() ),
189 or error( loc("couldn't locate current dir!") );
191 $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
193 my $id = $args->_store_id( $args );
195 unless ( $id == $args->_id ) {
196 error( loc("IDs do not match: %1 != %2. Storage failed!",
200 ### different source engines available now, so set them here
201 { my $store = $conf->get_conf( 'source_engine' )
202 || DEFAULT_SOURCE_ENGINE;
204 unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
205 error( loc( "Could not load source engine '%1'", $store ) );
207 if( $store ne DEFAULT_SOURCE_ENGINE ) {
208 msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
210 load DEFAULT_SOURCE_ENGINE;
212 base->import( DEFAULT_SOURCE_ENGINE );
217 base->import( $store );
226 =head2 $bool = $internals->_flush( list => \@caches )
228 Flushes the designated caches from the C<CPANPLUS> object.
230 Returns true on success, false if one or more caches could not be
237 my $conf = $self->configure_object;
242 list => { required => 1, default => [],
243 strict_type => 1, store => \$aref },
246 my $args = check( $tmpl, \%hash ) or return;
249 for my $what (@$aref) {
250 my $cache = '_' . $what;
252 ### set the include paths back to their original ###
253 if( $what eq 'lib' ) {
254 $ENV{PERL5LIB} = $conf->_perl5lib || '';
255 @INC = @{$conf->_lib};
257 ### give all modules a new status object -- this is slightly
258 ### costly, but the best way to make sure all statusses are
260 } elsif ( $what eq 'modules' ) {
261 for my $modobj ( values %{$self->module_tree} ) {
266 ### blow away the methods cache... currently, that's only
267 ### File::Fetch's method fail list
268 } elsif ( $what eq 'methods' ) {
270 ### still fucking p4 :( ###
271 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
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;
279 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
280 error( loc( "No such cache: '%1'", $what ) );
292 ### if extra callbacks are added, don't forget to update the
293 ### 02-internals.t test script with them!
297 =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
299 Registers a callback for later use by the internal libraries.
301 Here is a list of the currently used callbacks:
305 =item install_prerequisite
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.
311 =item send_test_report
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.
317 =item munge_test_report
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.
323 =item edit_test_report
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
330 =item proceed_on_test_failure
332 Is called when 'make test' or 'Build test' fails. Should return
333 a boolean indicating whether the install should continue even if
336 =item munge_dist_metafile
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.
347 sub _register_callback {
348 my $self = shift or return;
353 name => { required => 1, store => \$name,
354 allow => [$callback->ls_accessors] },
355 code => { required => 1, allow => IS_CODEREF,
359 check( $tmpl, \%hash ) or return;
361 $self->_callbacks->$name( $code ) or return;
366 # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
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
375 # sub _add_callback {
376 # my $self = shift or return;
381 # name => { required => 1, store => \$name, },
382 # code => { required => 1, allow => IS_CODEREF,
386 # check( $tmpl, \%hash ) or return;
388 # if( $callback->can( $name ) ) {
389 # error(loc("Callback '%1' is already registered"));
393 # $callback->mk_accessor( $name );
395 # $self->_register_callback( name => $name, code => $code ) or return;
404 =head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
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}>.
409 Returns true on success, false on failure.
413 sub _add_to_includepath {
419 directories => { required => 1, default => [], store => \$dirs,
423 check( $tmpl, \%hash ) or return;
425 my $s = $Config{'path_sep'};
427 ### only add if it's not added yet
428 for my $lib (@$dirs) {
429 push @INC, $lib unless grep { $_ eq $lib } @INC;
431 ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).
433 $ENV{'PERL5LIB'} .= $s . $lib
434 unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
442 =head2 $id = CPANPLUS::Internals->_last_id
444 Return the id of the last object stored.
446 =head2 $id = CPANPLUS::Internals->_store_id( $internals )
448 Store this object; return its id.
450 =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
452 Retrieve an object based on its ID -- return false on error.
454 =head2 CPANPLUS::Internals->_remove_id( $ID )
456 Remove the object marked by $ID from storage.
458 =head2 @objs = CPANPLUS::Internals->_return_all_objects
460 Return all stored objects.
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
473 sub _inc_id { return ++$count; }
475 sub _last_id { $count }
479 my $obj = shift or return;
481 unless( IS_INTERNALS_OBJ->($obj) ) {
482 error( loc("The object you passed has the wrong ref type: '%1'",
487 $idref->{ $obj->_id } = $obj;
493 my $id = shift or return;
495 my $obj = $idref->{$id};
501 my $id = shift or return;
503 return delete $idref->{$id};
506 sub _return_all_objects { return values %$idref }
512 # c-indentation-style: bsd
514 # indent-tabs-mode: nil
516 # vim: expandtab shiftwidth=4: