This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a CPANPLUS test that fails when run on a read-only source tree
[perl5.git] / lib / CPANPLUS / Internals.pm
CommitLineData
6aaee015
RGS
1package 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
5use 5.006001;
6
7use strict;
8use Config;
9
10
11use CPANPLUS::Error;
12
13use CPANPLUS::Selfupdate;
14
15use CPANPLUS::Internals::Source;
16use CPANPLUS::Internals::Extract;
17use CPANPLUS::Internals::Fetch;
18use CPANPLUS::Internals::Utils;
19use CPANPLUS::Internals::Constants;
20use CPANPLUS::Internals::Search;
21use CPANPLUS::Internals::Report;
22
23use Cwd qw[cwd];
24use Params::Check qw[check];
25use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
26
27use Object::Accessor;
28
29
30local $Params::Check::VERBOSE = 1;
31
32use vars qw[@ISA $VERSION];
33
34@ISA = qw[
35 CPANPLUS::Internals::Source
36 CPANPLUS::Internals::Extract
37 CPANPLUS::Internals::Fetch
38 CPANPLUS::Internals::Utils
39 CPANPLUS::Internals::Search
40 CPANPLUS::Internals::Report
41 ];
42
808cb88e 43$VERSION = "0.79_02";
6aaee015
RGS
44
45=pod
46
47=head1 NAME
48
49CPANPLUS::Internals
50
51=head1 SYNOPSIS
52
53 my $internals = CPANPLUS::Internals->_init( _conf => $conf );
54 my $backend = CPANPLUS::Internals->_retrieve_id( $ID );
55
56=head1 DESCRIPTION
57
58This module is the guts of CPANPLUS -- it inherits from all other
59modules in the CPANPLUS::Internals::* namespace, thus defying normal
60rules of OO programming -- but if you're reading this, you already
61know what's going on ;)
62
63Please read the C<CPANPLUS::Backend> documentation for the normal API.
64
65=head1 ACCESSORS
66
67=over 4
68
69=item _conf
70
71Get/set the configure object
72
73=item _id
74
75Get/set the id
76
77=item _lib
78
79Get/set the current @INC path -- @INC is reset to this after each
80install.
81
82=item _perl5lib
83
84Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB}
85is reset to this after each install.
86
87=cut
88
89### autogenerate accessors ###
90for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status
91 _callbacks _selfupdate]
92) {
93 no strict 'refs';
94 *{__PACKAGE__."::$key"} = sub {
95 $_[0]->{$key} = $_[1] if @_ > 1;
96 return $_[0]->{$key};
97 }
98}
99
100=pod
101
102=head1 METHODS
103
104=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
105
106C<_init> creates a new CPANPLUS::Internals object.
107
108You have to pass it a valid C<CPANPLUS::Configure> object.
109
110Returns the object on success, or dies on failure.
111
112=cut
113{ ### NOTE:
114 ### if extra callbacks are added, don't forget to update the
115 ### 02-internals.t test script with them!
116 my $callback_map = {
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] },
125 };
126
127 my $status = Object::Accessor->new;
128 $status->mk_accessors(qw[pending_prereqs]);
129
130 my $callback = Object::Accessor->new;
131 $callback->mk_accessors(keys %$callback_map);
132
133 my $conf;
134 my $Tmpl = {
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 },
146 };
147
148 sub _init {
149 my $class = shift;
150 my %hash = @_;
151
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);
159
160 return $class->_retrieve_id( $id );
161 }
162
163 my $args = check($Tmpl, \%hash)
164 or die loc(qq[Could not initialize '%1' object], $class);
165
166 bless $args, $class;
167
168 $args->{'_id'} = $args->_inc_id;
169 $args->{'_status'} = $status;
170 $args->{'_callbacks'} = $callback;
171
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';
176
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};
183 }
184 );
185 }
186
187 ### create a selfupdate object
188 $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
189
190 ### initalize it as an empty hashref ###
191 $args->_status->pending_prereqs( {} );
192
193 ### allow for dirs to be added to @INC at runtime,
194 ### rather then compile time
195 push @INC, @{$conf->get_conf('lib')};
196
197 ### add any possible new dirs ###
198 $args->_lib( [@INC] );
199
200 $conf->_set_build( startdir => cwd() ),
201 or error( loc("couldn't locate current dir!") );
202
203 $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
204
205 my $id = $args->_store_id( $args );
206
207 unless ( $id == $args->_id ) {
208 error( loc("IDs do not match: %1 != %2. Storage failed!",
209 $id, $args->_id) );
210 }
211
212 return $args;
213 }
214
215=pod
216
217=head2 $bool = $internals->_flush( list => \@caches )
218
219Flushes the designated caches from the C<CPANPLUS> object.
220
221Returns true on success, false if one or more caches could not be
222be flushed.
223
224=cut
225
226 sub _flush {
227 my $self = shift;
228 my %hash = @_;
229
230 my $aref;
231 my $tmpl = {
232 list => { required => 1, default => [],
233 strict_type => 1, store => \$aref },
234 };
235
236 my $args = check( $tmpl, \%hash ) or return;
237
238 my $flag = 0;
239 for my $what (@$aref) {
240 my $cache = '_' . $what;
241
242 ### set the include paths back to their original ###
243 if( $what eq 'lib' ) {
244 $ENV{PERL5LIB} = $self->_perl5lib || '';
245 @INC = @{$self->_lib};
246
247 ### give all modules a new status object -- this is slightly
248 ### costly, but the best way to make sure all statusses are
249 ### forgotten --kane
250 } elsif ( $what eq 'modules' ) {
251 for my $modobj ( values %{$self->module_tree} ) {
252 $modobj->_flush;
253 }
254
255 ### blow away the methods cache... currently, that's only
256 ### File::Fetch's method fail list
257 } elsif ( $what eq 'methods' ) {
258
259 ### still fucking p4 :( ###
260 $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
261
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;
266
267 } else {
268 unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
269 error( loc( "No such cache: '%1'", $what ) );
270 $flag++;
271 next;
272 } else {
273 $self->$cache( {} );
274 }
275 }
276 }
277 return !$flag;
278 }
279
280### NOTE:
281### if extra callbacks are added, don't forget to update the
282### 02-internals.t test script with them!
283
284=pod
285
286=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
287
288Registers a callback for later use by the internal libraries.
289
290Here is a list of the currently used callbacks:
291
292=over 4
293
294=item install_prerequisite
295
296Is called when the user wants to be C<asked> about what to do with
297prerequisites. Should return a boolean indicating true to install
298the prerequisite and false to skip it.
299
300=item send_test_report
301
302Is called when the user should be prompted if he wishes to send the
303test report. Should return a boolean indicating true to send the
304test report and false to skip it.
305
306=item munge_test_report
307
308Is called when the test report message has been composed, giving
309the user a chance to programatically alter it. Should return the
310(munged) message to be sent.
311
312=item edit_test_report
313
314Is called when the user should be prompted to edit test reports
315about to be sent out by Test::Reporter. Should return a boolean
316indicating true to edit the test report in an editor and false
317to skip it.
318
319=back
320
321=cut
322
323 sub _register_callback {
324 my $self = shift or return;
325 my %hash = @_;
326
327 my ($name,$code);
328 my $tmpl = {
329 name => { required => 1, store => \$name,
330 allow => [$callback->ls_accessors] },
331 code => { required => 1, allow => IS_CODEREF,
332 store => \$code },
333 };
334
335 check( $tmpl, \%hash ) or return;
336
337 $self->_callbacks->$name( $code ) or return;
338
339 return 1;
340 }
341
342# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
343#
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
347# using the
348#
349# =cut
350#
351# sub _add_callback {
352# my $self = shift or return;
353# my %hash = @_;
354#
355# my ($name,$code);
356# my $tmpl = {
357# name => { required => 1, store => \$name, },
358# code => { required => 1, allow => IS_CODEREF,
359# store => \$code },
360# };
361#
362# check( $tmpl, \%hash ) or return;
363#
364# if( $callback->can( $name ) ) {
365# error(loc("Callback '%1' is already registered"));
366# return;
367# }
368#
369# $callback->mk_accessor( $name );
370#
371# $self->_register_callback( name => $name, code => $code ) or return;
372#
373# return 1;
374# }
375
376}
377
378=pod
379
380=head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
381
382Adds a list of directories to the include path.
383This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
384
385Returns true on success, false on failure.
386
387=cut
388
389sub _add_to_includepath {
390 my $self = shift;
391 my %hash = @_;
392
393 my $dirs;
394 my $tmpl = {
395 directories => { required => 1, default => [], store => \$dirs,
396 strict_type => 1 },
397 };
398
399 check( $tmpl, \%hash ) or return;
400
401 for my $lib (@$dirs) {
402 push @INC, $lib unless grep { $_ eq $lib } @INC;
403 }
404
405 { local $^W; ### it will be complaining if $ENV{PERL5LIB]
406 ### is not defined (yet).
407 $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs;
408 }
409
410 return 1;
411}
412
413=pod
414
415=head2 $id = CPANPLUS::Internals->_last_id
416
417Return the id of the last object stored.
418
419=head2 $id = CPANPLUS::Internals->_store_id( $internals )
420
421Store this object; return its id.
422
423=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
424
425Retrieve an object based on its ID -- return false on error.
426
427=head2 CPANPLUS::Internals->_remove_id( $ID )
428
429Remove the object marked by $ID from storage.
430
431=head2 @objs = CPANPLUS::Internals->_return_all_objects
432
433Return all stored objects.
434
435=cut
436
437
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
441### to change
442{
443 my $idref = {};
444 my $count = 0;
445
446 sub _inc_id { return ++$count; }
447
448 sub _last_id { $count }
449
450 sub _store_id {
451 my $self = shift;
452 my $obj = shift or return;
453
454 unless( IS_INTERNALS_OBJ->($obj) ) {
455 error( loc("The object you passed has the wrong ref type: '%1'",
456 ref $obj) );
457 return;
458 }
459
460 $idref->{ $obj->_id } = $obj;
461 return $obj->_id;
462 }
463
464 sub _retrieve_id {
465 my $self = shift;
466 my $id = shift or return;
467
468 my $obj = $idref->{$id};
469 return $obj;
470 }
471
472 sub _remove_id {
473 my $self = shift;
474 my $id = shift or return;
475
476 return delete $idref->{$id};
477 }
478
479 sub _return_all_objects { return values %$idref }
480}
481
4821;
483
484# Local variables:
485# c-indentation-style: bsd
486# c-basic-offset: 4
487# indent-tabs-mode: nil
488# End:
489# vim: expandtab shiftwidth=4: