Commit | Line | Data |
6aaee015 |
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 | use 5.006001; |
6 | |
7 | use strict; |
8 | use Config; |
9 | |
10 | |
11 | use CPANPLUS::Error; |
12 | |
13 | use CPANPLUS::Selfupdate; |
14 | |
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; |
22 | |
23 | use Cwd qw[cwd]; |
24 | use Params::Check qw[check]; |
25 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
26 | |
27 | use Object::Accessor; |
28 | |
29 | |
30 | local $Params::Check::VERBOSE = 1; |
31 | |
32 | use 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 | |
502c7995 |
43 | $VERSION = "0.81_01"; |
6aaee015 |
44 | |
45 | =pod |
46 | |
47 | =head1 NAME |
48 | |
49 | CPANPLUS::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 | |
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 ;) |
62 | |
63 | Please read the C<CPANPLUS::Backend> documentation for the normal API. |
64 | |
65 | =head1 ACCESSORS |
66 | |
67 | =over 4 |
68 | |
69 | =item _conf |
70 | |
71 | Get/set the configure object |
72 | |
73 | =item _id |
74 | |
75 | Get/set the id |
76 | |
77 | =item _lib |
78 | |
79 | Get/set the current @INC path -- @INC is reset to this after each |
80 | install. |
81 | |
82 | =item _perl5lib |
83 | |
84 | Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB} |
85 | is reset to this after each install. |
86 | |
87 | =cut |
88 | |
89 | ### autogenerate accessors ### |
90 | for 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 | |
622d31ac |
102 | =back |
103 | |
6aaee015 |
104 | =head1 METHODS |
105 | |
106 | =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) |
107 | |
108 | C<_init> creates a new CPANPLUS::Internals object. |
109 | |
110 | You have to pass it a valid C<CPANPLUS::Configure> object. |
111 | |
112 | Returns the object on success, or dies on failure. |
113 | |
114 | =cut |
115 | { ### NOTE: |
116 | ### if extra callbacks are added, don't forget to update the |
117 | ### 02-internals.t test script with them! |
118 | my $callback_map = { |
622d31ac |
119 | ### name default value |
6aaee015 |
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] }, |
622d31ac |
127 | # continue if 'make test' fails? |
128 | proceed_on_test_failure => sub { return 0 }, |
502c7995 |
129 | munge_dist_metafile => sub { return $_[1] }, |
6aaee015 |
130 | }; |
131 | |
132 | my $status = Object::Accessor->new; |
133 | $status->mk_accessors(qw[pending_prereqs]); |
134 | |
135 | my $callback = Object::Accessor->new; |
136 | $callback->mk_accessors(keys %$callback_map); |
137 | |
138 | my $conf; |
139 | my $Tmpl = { |
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 }, |
151 | }; |
152 | |
153 | sub _init { |
154 | my $class = shift; |
155 | my %hash = @_; |
156 | |
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); |
164 | |
165 | return $class->_retrieve_id( $id ); |
166 | } |
167 | |
168 | my $args = check($Tmpl, \%hash) |
169 | or die loc(qq[Could not initialize '%1' object], $class); |
170 | |
171 | bless $args, $class; |
172 | |
173 | $args->{'_id'} = $args->_inc_id; |
174 | $args->{'_status'} = $status; |
175 | $args->{'_callbacks'} = $callback; |
176 | |
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'; |
181 | |
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}; |
188 | } |
189 | ); |
190 | } |
191 | |
192 | ### create a selfupdate object |
193 | $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) ); |
194 | |
195 | ### initalize it as an empty hashref ### |
196 | $args->_status->pending_prereqs( {} ); |
197 | |
198 | ### allow for dirs to be added to @INC at runtime, |
199 | ### rather then compile time |
200 | push @INC, @{$conf->get_conf('lib')}; |
201 | |
202 | ### add any possible new dirs ### |
203 | $args->_lib( [@INC] ); |
204 | |
205 | $conf->_set_build( startdir => cwd() ), |
206 | or error( loc("couldn't locate current dir!") ); |
207 | |
208 | $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive'); |
209 | |
210 | my $id = $args->_store_id( $args ); |
211 | |
212 | unless ( $id == $args->_id ) { |
213 | error( loc("IDs do not match: %1 != %2. Storage failed!", |
214 | $id, $args->_id) ); |
215 | } |
216 | |
217 | return $args; |
218 | } |
219 | |
220 | =pod |
221 | |
222 | =head2 $bool = $internals->_flush( list => \@caches ) |
223 | |
224 | Flushes the designated caches from the C<CPANPLUS> object. |
225 | |
226 | Returns true on success, false if one or more caches could not be |
227 | be flushed. |
228 | |
229 | =cut |
230 | |
231 | sub _flush { |
232 | my $self = shift; |
233 | my %hash = @_; |
234 | |
235 | my $aref; |
236 | my $tmpl = { |
237 | list => { required => 1, default => [], |
238 | strict_type => 1, store => \$aref }, |
239 | }; |
240 | |
241 | my $args = check( $tmpl, \%hash ) or return; |
242 | |
243 | my $flag = 0; |
244 | for my $what (@$aref) { |
245 | my $cache = '_' . $what; |
246 | |
247 | ### set the include paths back to their original ### |
248 | if( $what eq 'lib' ) { |
249 | $ENV{PERL5LIB} = $self->_perl5lib || ''; |
250 | @INC = @{$self->_lib}; |
251 | |
252 | ### give all modules a new status object -- this is slightly |
253 | ### costly, but the best way to make sure all statusses are |
254 | ### forgotten --kane |
255 | } elsif ( $what eq 'modules' ) { |
256 | for my $modobj ( values %{$self->module_tree} ) { |
257 | $modobj->_flush; |
258 | } |
259 | |
260 | ### blow away the methods cache... currently, that's only |
261 | ### File::Fetch's method fail list |
262 | } elsif ( $what eq 'methods' ) { |
263 | |
264 | ### still fucking p4 :( ### |
265 | $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {}; |
266 | |
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; |
271 | |
272 | } else { |
273 | unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) { |
274 | error( loc( "No such cache: '%1'", $what ) ); |
275 | $flag++; |
276 | next; |
277 | } else { |
278 | $self->$cache( {} ); |
279 | } |
280 | } |
281 | } |
282 | return !$flag; |
283 | } |
284 | |
285 | ### NOTE: |
286 | ### if extra callbacks are added, don't forget to update the |
287 | ### 02-internals.t test script with them! |
288 | |
289 | =pod |
290 | |
291 | =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF ); |
292 | |
293 | Registers a callback for later use by the internal libraries. |
294 | |
295 | Here is a list of the currently used callbacks: |
296 | |
297 | =over 4 |
298 | |
299 | =item install_prerequisite |
300 | |
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. |
304 | |
305 | =item send_test_report |
306 | |
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. |
310 | |
311 | =item munge_test_report |
312 | |
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. |
316 | |
317 | =item edit_test_report |
318 | |
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 |
322 | to skip it. |
323 | |
622d31ac |
324 | =item proceed_on_test_failure |
325 | |
326 | Is called when 'make test' or 'Build test' fails. Should return |
327 | a boolean indicating whether the install should continue even if |
328 | the test failed. |
329 | |
502c7995 |
330 | =item munge_dist_metafile |
331 | |
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. |
336 | |
6aaee015 |
337 | =back |
338 | |
339 | =cut |
340 | |
341 | sub _register_callback { |
342 | my $self = shift or return; |
343 | my %hash = @_; |
344 | |
345 | my ($name,$code); |
346 | my $tmpl = { |
347 | name => { required => 1, store => \$name, |
348 | allow => [$callback->ls_accessors] }, |
349 | code => { required => 1, allow => IS_CODEREF, |
350 | store => \$code }, |
351 | }; |
352 | |
353 | check( $tmpl, \%hash ) or return; |
354 | |
355 | $self->_callbacks->$name( $code ) or return; |
356 | |
357 | return 1; |
358 | } |
359 | |
360 | # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF ); |
361 | # |
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 |
365 | # using the |
366 | # |
367 | # =cut |
368 | # |
369 | # sub _add_callback { |
370 | # my $self = shift or return; |
371 | # my %hash = @_; |
372 | # |
373 | # my ($name,$code); |
374 | # my $tmpl = { |
375 | # name => { required => 1, store => \$name, }, |
376 | # code => { required => 1, allow => IS_CODEREF, |
377 | # store => \$code }, |
378 | # }; |
379 | # |
380 | # check( $tmpl, \%hash ) or return; |
381 | # |
382 | # if( $callback->can( $name ) ) { |
383 | # error(loc("Callback '%1' is already registered")); |
384 | # return; |
385 | # } |
386 | # |
387 | # $callback->mk_accessor( $name ); |
388 | # |
389 | # $self->_register_callback( name => $name, code => $code ) or return; |
390 | # |
391 | # return 1; |
392 | # } |
393 | |
394 | } |
395 | |
396 | =pod |
397 | |
398 | =head2 $bool = $internals->_add_to_includepath( directories => \@dirs ) |
399 | |
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}>. |
402 | |
403 | Returns true on success, false on failure. |
404 | |
405 | =cut |
406 | |
407 | sub _add_to_includepath { |
408 | my $self = shift; |
409 | my %hash = @_; |
410 | |
411 | my $dirs; |
412 | my $tmpl = { |
413 | directories => { required => 1, default => [], store => \$dirs, |
414 | strict_type => 1 }, |
415 | }; |
416 | |
417 | check( $tmpl, \%hash ) or return; |
418 | |
419 | for my $lib (@$dirs) { |
420 | push @INC, $lib unless grep { $_ eq $lib } @INC; |
421 | } |
422 | |
423 | { local $^W; ### it will be complaining if $ENV{PERL5LIB] |
424 | ### is not defined (yet). |
425 | $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs; |
426 | } |
427 | |
428 | return 1; |
429 | } |
430 | |
431 | =pod |
432 | |
433 | =head2 $id = CPANPLUS::Internals->_last_id |
434 | |
435 | Return the id of the last object stored. |
436 | |
437 | =head2 $id = CPANPLUS::Internals->_store_id( $internals ) |
438 | |
439 | Store this object; return its id. |
440 | |
441 | =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) |
442 | |
443 | Retrieve an object based on its ID -- return false on error. |
444 | |
445 | =head2 CPANPLUS::Internals->_remove_id( $ID ) |
446 | |
447 | Remove the object marked by $ID from storage. |
448 | |
449 | =head2 @objs = CPANPLUS::Internals->_return_all_objects |
450 | |
451 | Return all stored objects. |
452 | |
453 | =cut |
454 | |
455 | |
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 |
459 | ### to change |
460 | { |
461 | my $idref = {}; |
462 | my $count = 0; |
463 | |
464 | sub _inc_id { return ++$count; } |
465 | |
466 | sub _last_id { $count } |
467 | |
468 | sub _store_id { |
469 | my $self = shift; |
470 | my $obj = shift or return; |
471 | |
472 | unless( IS_INTERNALS_OBJ->($obj) ) { |
473 | error( loc("The object you passed has the wrong ref type: '%1'", |
474 | ref $obj) ); |
475 | return; |
476 | } |
477 | |
478 | $idref->{ $obj->_id } = $obj; |
479 | return $obj->_id; |
480 | } |
481 | |
482 | sub _retrieve_id { |
483 | my $self = shift; |
484 | my $id = shift or return; |
485 | |
486 | my $obj = $idref->{$id}; |
487 | return $obj; |
488 | } |
489 | |
490 | sub _remove_id { |
491 | my $self = shift; |
492 | my $id = shift or return; |
493 | |
494 | return delete $idref->{$id}; |
495 | } |
496 | |
497 | sub _return_all_objects { return values %$idref } |
498 | } |
499 | |
500 | 1; |
501 | |
502 | # Local variables: |
503 | # c-indentation-style: bsd |
504 | # c-basic-offset: 4 |
505 | # indent-tabs-mode: nil |
506 | # End: |
507 | # vim: expandtab shiftwidth=4: |