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;
104 =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
106 C<_init> creates a new CPANPLUS::Internals object.
108 You have to pass it a valid C<CPANPLUS::Configure> object.
110 Returns the object on success, or dies on failure.
114 ### if extra callbacks are added, don't forget to update the
115 ### 02-internals.t test script with them!
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] },
127 my $status = Object::Accessor->new;
128 $status->mk_accessors(qw[pending_prereqs]);
130 my $callback = Object::Accessor->new;
131 $callback->mk_accessors(keys %$callback_map);
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 },
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);
160 return $class->_retrieve_id( $id );
163 my $args = check($Tmpl, \%hash)
164 or die loc(qq[Could not initialize '%1' object], $class);
168 $args->{'_id'} = $args->_inc_id;
169 $args->{'_status'} = $status;
170 $args->{'_callbacks'} = $callback;
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';
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};
187 ### create a selfupdate object
188 $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
190 ### initalize it as an empty hashref ###
191 $args->_status->pending_prereqs( {} );
193 ### allow for dirs to be added to @INC at runtime,
194 ### rather then compile time
195 push @INC, @{$conf->get_conf('lib')};
197 ### add any possible new dirs ###
198 $args->_lib( [@INC] );
200 $conf->_set_build( startdir => cwd() ),
201 or error( loc("couldn't locate current dir!") );
203 $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
205 my $id = $args->_store_id( $args );
207 unless ( $id == $args->_id ) {
208 error( loc("IDs do not match: %1 != %2. Storage failed!",
217 =head2 $bool = $internals->_flush( list => \@caches )
219 Flushes the designated caches from the C<CPANPLUS> object.
221 Returns true on success, false if one or more caches could not be
232 list => { required => 1, default => [],
233 strict_type => 1, store => \$aref },
236 my $args = check( $tmpl, \%hash ) or return;
239 for my $what (@$aref) {
240 my $cache = '_' . $what;
242 ### set the include paths back to their original ###
243 if( $what eq 'lib' ) {
244 $ENV{PERL5LIB} = $self->_perl5lib || '';
245 @INC = @{$self->_lib};
247 ### give all modules a new status object -- this is slightly
248 ### costly, but the best way to make sure all statusses are
250 } elsif ( $what eq 'modules' ) {
251 for my $modobj ( values %{$self->module_tree} ) {
255 ### blow away the methods cache... currently, that's only
256 ### File::Fetch's method fail list
257 } elsif ( $what eq 'methods' ) {
259 ### still fucking p4 :( ###
260 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
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;
268 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
269 error( loc( "No such cache: '%1'", $what ) );
281 ### if extra callbacks are added, don't forget to update the
282 ### 02-internals.t test script with them!
286 =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
288 Registers a callback for later use by the internal libraries.
290 Here is a list of the currently used callbacks:
294 =item install_prerequisite
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.
300 =item send_test_report
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.
306 =item munge_test_report
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.
312 =item edit_test_report
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
323 sub _register_callback {
324 my $self = shift or return;
329 name => { required => 1, store => \$name,
330 allow => [$callback->ls_accessors] },
331 code => { required => 1, allow => IS_CODEREF,
335 check( $tmpl, \%hash ) or return;
337 $self->_callbacks->$name( $code ) or return;
342 # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
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
351 # sub _add_callback {
352 # my $self = shift or return;
357 # name => { required => 1, store => \$name, },
358 # code => { required => 1, allow => IS_CODEREF,
362 # check( $tmpl, \%hash ) or return;
364 # if( $callback->can( $name ) ) {
365 # error(loc("Callback '%1' is already registered"));
369 # $callback->mk_accessor( $name );
371 # $self->_register_callback( name => $name, code => $code ) or return;
380 =head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
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}>.
385 Returns true on success, false on failure.
389 sub _add_to_includepath {
395 directories => { required => 1, default => [], store => \$dirs,
399 check( $tmpl, \%hash ) or return;
401 for my $lib (@$dirs) {
402 push @INC, $lib unless grep { $_ eq $lib } @INC;
405 { local $^W; ### it will be complaining if $ENV{PERL5LIB]
406 ### is not defined (yet).
407 $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs;
415 =head2 $id = CPANPLUS::Internals->_last_id
417 Return the id of the last object stored.
419 =head2 $id = CPANPLUS::Internals->_store_id( $internals )
421 Store this object; return its id.
423 =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
425 Retrieve an object based on its ID -- return false on error.
427 =head2 CPANPLUS::Internals->_remove_id( $ID )
429 Remove the object marked by $ID from storage.
431 =head2 @objs = CPANPLUS::Internals->_return_all_objects
433 Return all stored objects.
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
446 sub _inc_id { return ++$count; }
448 sub _last_id { $count }
452 my $obj = shift or return;
454 unless( IS_INTERNALS_OBJ->($obj) ) {
455 error( loc("The object you passed has the wrong ref type: '%1'",
460 $idref->{ $obj->_id } = $obj;
466 my $id = shift or return;
468 my $obj = $idref->{$id};
474 my $id = shift or return;
476 return delete $idref->{$id};
479 sub _return_all_objects { return values %$idref }
485 # c-indentation-style: bsd
487 # indent-tabs-mode: nil
489 # vim: expandtab shiftwidth=4: