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 | |
6aaee015 |
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; |
21 | |
4443dd53 |
22 | |
23 | require base; |
6aaee015 |
24 | use Cwd qw[cwd]; |
4443dd53 |
25 | use Module::Load qw[load]; |
6aaee015 |
26 | use Params::Check qw[check]; |
27 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
4443dd53 |
28 | use Module::Load::Conditional qw[can_load]; |
6aaee015 |
29 | |
30 | use Object::Accessor; |
31 | |
32 | |
33 | local $Params::Check::VERBOSE = 1; |
34 | |
35 | use vars qw[@ISA $VERSION]; |
36 | |
37 | @ISA = qw[ |
6aaee015 |
38 | CPANPLUS::Internals::Extract |
39 | CPANPLUS::Internals::Fetch |
40 | CPANPLUS::Internals::Utils |
41 | CPANPLUS::Internals::Search |
42 | CPANPLUS::Internals::Report |
43 | ]; |
44 | |
4443dd53 |
45 | $VERSION = "0.86_06"; |
6aaee015 |
46 | |
47 | =pod |
48 | |
49 | =head1 NAME |
50 | |
51 | CPANPLUS::Internals |
52 | |
53 | =head1 SYNOPSIS |
54 | |
55 | my $internals = CPANPLUS::Internals->_init( _conf => $conf ); |
56 | my $backend = CPANPLUS::Internals->_retrieve_id( $ID ); |
57 | |
58 | =head1 DESCRIPTION |
59 | |
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 ;) |
64 | |
65 | Please read the C<CPANPLUS::Backend> documentation for the normal API. |
66 | |
67 | =head1 ACCESSORS |
68 | |
69 | =over 4 |
70 | |
71 | =item _conf |
72 | |
73 | Get/set the configure object |
74 | |
75 | =item _id |
76 | |
77 | Get/set the id |
78 | |
6aaee015 |
79 | =cut |
80 | |
81 | ### autogenerate accessors ### |
4443dd53 |
82 | for my $key ( qw[_conf _id _modules _hosts _methods _status |
83 | _callbacks _selfupdate _mtree _atree] |
6aaee015 |
84 | ) { |
85 | no strict 'refs'; |
86 | *{__PACKAGE__."::$key"} = sub { |
87 | $_[0]->{$key} = $_[1] if @_ > 1; |
88 | return $_[0]->{$key}; |
89 | } |
90 | } |
91 | |
92 | =pod |
93 | |
622d31ac |
94 | =back |
95 | |
6aaee015 |
96 | =head1 METHODS |
97 | |
98 | =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) |
99 | |
100 | C<_init> creates a new CPANPLUS::Internals object. |
101 | |
102 | You have to pass it a valid C<CPANPLUS::Configure> object. |
103 | |
104 | Returns the object on success, or dies on failure. |
105 | |
106 | =cut |
107 | { ### NOTE: |
108 | ### if extra callbacks are added, don't forget to update the |
109 | ### 02-internals.t test script with them! |
110 | my $callback_map = { |
622d31ac |
111 | ### name default value |
6aaee015 |
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] }, |
622d31ac |
119 | # continue if 'make test' fails? |
120 | proceed_on_test_failure => sub { return 0 }, |
502c7995 |
121 | munge_dist_metafile => sub { return $_[1] }, |
6aaee015 |
122 | }; |
123 | |
124 | my $status = Object::Accessor->new; |
125 | $status->mk_accessors(qw[pending_prereqs]); |
126 | |
127 | my $callback = Object::Accessor->new; |
128 | $callback->mk_accessors(keys %$callback_map); |
129 | |
130 | my $conf; |
131 | my $Tmpl = { |
132 | _conf => { required => 1, store => \$conf, |
133 | allow => IS_CONFOBJ }, |
134 | _id => { default => '', no_override => 1 }, |
6aaee015 |
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 }, |
141 | }; |
142 | |
143 | sub _init { |
144 | my $class = shift; |
145 | my %hash = @_; |
146 | |
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 ] . |
d0baa00e |
153 | qq[running program\n], 'CPANPLUS', $class); |
6aaee015 |
154 | |
155 | return $class->_retrieve_id( $id ); |
156 | } |
157 | |
158 | my $args = check($Tmpl, \%hash) |
159 | or die loc(qq[Could not initialize '%1' object], $class); |
160 | |
161 | bless $args, $class; |
162 | |
163 | $args->{'_id'} = $args->_inc_id; |
164 | $args->{'_status'} = $status; |
165 | $args->{'_callbacks'} = $callback; |
166 | |
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'; |
171 | |
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}; |
178 | } |
179 | ); |
180 | } |
181 | |
182 | ### create a selfupdate object |
183 | $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) ); |
184 | |
185 | ### initalize it as an empty hashref ### |
186 | $args->_status->pending_prereqs( {} ); |
187 | |
6aaee015 |
188 | $conf->_set_build( startdir => cwd() ), |
189 | or error( loc("couldn't locate current dir!") ); |
190 | |
191 | $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive'); |
192 | |
193 | my $id = $args->_store_id( $args ); |
194 | |
195 | unless ( $id == $args->_id ) { |
196 | error( loc("IDs do not match: %1 != %2. Storage failed!", |
197 | $id, $args->_id) ); |
198 | } |
199 | |
4443dd53 |
200 | ### different source engines available now, so set them here |
201 | { my $store = $conf->get_conf( 'source_engine' ) |
202 | || DEFAULT_SOURCE_ENGINE; |
203 | |
204 | unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) { |
205 | error( loc( "Could not load source engine '%1'", $store ) ); |
206 | |
207 | if( $store ne DEFAULT_SOURCE_ENGINE ) { |
208 | msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 ); |
209 | |
210 | load DEFAULT_SOURCE_ENGINE; |
211 | |
212 | base->import( DEFAULT_SOURCE_ENGINE ); |
213 | } else { |
214 | return; |
215 | } |
216 | } else { |
217 | base->import( $store ); |
218 | } |
219 | } |
220 | |
6aaee015 |
221 | return $args; |
222 | } |
223 | |
224 | =pod |
225 | |
226 | =head2 $bool = $internals->_flush( list => \@caches ) |
227 | |
228 | Flushes the designated caches from the C<CPANPLUS> object. |
229 | |
230 | Returns true on success, false if one or more caches could not be |
231 | be flushed. |
232 | |
233 | =cut |
234 | |
235 | sub _flush { |
236 | my $self = shift; |
4443dd53 |
237 | my $conf = $self->configure_object; |
6aaee015 |
238 | my %hash = @_; |
239 | |
240 | my $aref; |
241 | my $tmpl = { |
242 | list => { required => 1, default => [], |
243 | strict_type => 1, store => \$aref }, |
244 | }; |
245 | |
246 | my $args = check( $tmpl, \%hash ) or return; |
247 | |
248 | my $flag = 0; |
249 | for my $what (@$aref) { |
250 | my $cache = '_' . $what; |
251 | |
252 | ### set the include paths back to their original ### |
253 | if( $what eq 'lib' ) { |
4443dd53 |
254 | $ENV{PERL5LIB} = $conf->_perl5lib || ''; |
255 | @INC = @{$conf->_lib}; |
6aaee015 |
256 | |
257 | ### give all modules a new status object -- this is slightly |
258 | ### costly, but the best way to make sure all statusses are |
259 | ### forgotten --kane |
260 | } elsif ( $what eq 'modules' ) { |
261 | for my $modobj ( values %{$self->module_tree} ) { |
4443dd53 |
262 | |
6aaee015 |
263 | $modobj->_flush; |
264 | } |
265 | |
266 | ### blow away the methods cache... currently, that's only |
267 | ### File::Fetch's method fail list |
268 | } elsif ( $what eq 'methods' ) { |
269 | |
270 | ### still fucking p4 :( ### |
271 | $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {}; |
272 | |
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; |
277 | |
278 | } else { |
279 | unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) { |
280 | error( loc( "No such cache: '%1'", $what ) ); |
281 | $flag++; |
282 | next; |
283 | } else { |
284 | $self->$cache( {} ); |
285 | } |
286 | } |
287 | } |
288 | return !$flag; |
289 | } |
290 | |
291 | ### NOTE: |
292 | ### if extra callbacks are added, don't forget to update the |
293 | ### 02-internals.t test script with them! |
294 | |
295 | =pod |
296 | |
297 | =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF ); |
298 | |
299 | Registers a callback for later use by the internal libraries. |
300 | |
301 | Here is a list of the currently used callbacks: |
302 | |
303 | =over 4 |
304 | |
305 | =item install_prerequisite |
306 | |
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. |
310 | |
311 | =item send_test_report |
312 | |
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. |
316 | |
317 | =item munge_test_report |
318 | |
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. |
322 | |
323 | =item edit_test_report |
324 | |
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 |
328 | to skip it. |
329 | |
622d31ac |
330 | =item proceed_on_test_failure |
331 | |
332 | Is called when 'make test' or 'Build test' fails. Should return |
333 | a boolean indicating whether the install should continue even if |
334 | the test failed. |
335 | |
502c7995 |
336 | =item munge_dist_metafile |
337 | |
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. |
342 | |
6aaee015 |
343 | =back |
344 | |
345 | =cut |
346 | |
347 | sub _register_callback { |
348 | my $self = shift or return; |
349 | my %hash = @_; |
350 | |
351 | my ($name,$code); |
352 | my $tmpl = { |
353 | name => { required => 1, store => \$name, |
354 | allow => [$callback->ls_accessors] }, |
355 | code => { required => 1, allow => IS_CODEREF, |
356 | store => \$code }, |
357 | }; |
358 | |
359 | check( $tmpl, \%hash ) or return; |
360 | |
361 | $self->_callbacks->$name( $code ) or return; |
362 | |
363 | return 1; |
364 | } |
365 | |
366 | # =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF ); |
367 | # |
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 |
371 | # using the |
372 | # |
373 | # =cut |
374 | # |
375 | # sub _add_callback { |
376 | # my $self = shift or return; |
377 | # my %hash = @_; |
378 | # |
379 | # my ($name,$code); |
380 | # my $tmpl = { |
381 | # name => { required => 1, store => \$name, }, |
382 | # code => { required => 1, allow => IS_CODEREF, |
383 | # store => \$code }, |
384 | # }; |
385 | # |
386 | # check( $tmpl, \%hash ) or return; |
387 | # |
388 | # if( $callback->can( $name ) ) { |
389 | # error(loc("Callback '%1' is already registered")); |
390 | # return; |
391 | # } |
392 | # |
393 | # $callback->mk_accessor( $name ); |
394 | # |
395 | # $self->_register_callback( name => $name, code => $code ) or return; |
396 | # |
397 | # return 1; |
398 | # } |
399 | |
400 | } |
401 | |
402 | =pod |
403 | |
404 | =head2 $bool = $internals->_add_to_includepath( directories => \@dirs ) |
405 | |
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}>. |
408 | |
409 | Returns true on success, false on failure. |
410 | |
411 | =cut |
412 | |
413 | sub _add_to_includepath { |
414 | my $self = shift; |
415 | my %hash = @_; |
416 | |
417 | my $dirs; |
418 | my $tmpl = { |
419 | directories => { required => 1, default => [], store => \$dirs, |
420 | strict_type => 1 }, |
421 | }; |
422 | |
423 | check( $tmpl, \%hash ) or return; |
424 | |
425 | for my $lib (@$dirs) { |
426 | push @INC, $lib unless grep { $_ eq $lib } @INC; |
427 | } |
428 | |
429 | { local $^W; ### it will be complaining if $ENV{PERL5LIB] |
430 | ### is not defined (yet). |
431 | $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs; |
432 | } |
433 | |
434 | return 1; |
435 | } |
436 | |
437 | =pod |
438 | |
439 | =head2 $id = CPANPLUS::Internals->_last_id |
440 | |
441 | Return the id of the last object stored. |
442 | |
443 | =head2 $id = CPANPLUS::Internals->_store_id( $internals ) |
444 | |
445 | Store this object; return its id. |
446 | |
447 | =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) |
448 | |
449 | Retrieve an object based on its ID -- return false on error. |
450 | |
451 | =head2 CPANPLUS::Internals->_remove_id( $ID ) |
452 | |
453 | Remove the object marked by $ID from storage. |
454 | |
455 | =head2 @objs = CPANPLUS::Internals->_return_all_objects |
456 | |
457 | Return all stored objects. |
458 | |
459 | =cut |
460 | |
461 | |
462 | ### code for storing multiple objects |
463 | ### -- although we only support one right now |
464 | ### XXX when support for multiple objects comes, saving source will have |
465 | ### to change |
466 | { |
467 | my $idref = {}; |
468 | my $count = 0; |
469 | |
470 | sub _inc_id { return ++$count; } |
471 | |
472 | sub _last_id { $count } |
473 | |
474 | sub _store_id { |
475 | my $self = shift; |
476 | my $obj = shift or return; |
477 | |
478 | unless( IS_INTERNALS_OBJ->($obj) ) { |
479 | error( loc("The object you passed has the wrong ref type: '%1'", |
480 | ref $obj) ); |
481 | return; |
482 | } |
483 | |
484 | $idref->{ $obj->_id } = $obj; |
485 | return $obj->_id; |
486 | } |
487 | |
488 | sub _retrieve_id { |
489 | my $self = shift; |
490 | my $id = shift or return; |
491 | |
492 | my $obj = $idref->{$id}; |
493 | return $obj; |
494 | } |
495 | |
496 | sub _remove_id { |
497 | my $self = shift; |
498 | my $id = shift or return; |
499 | |
500 | return delete $idref->{$id}; |
501 | } |
502 | |
503 | sub _return_all_objects { return values %$idref } |
504 | } |
505 | |
506 | 1; |
507 | |
508 | # Local variables: |
509 | # c-indentation-style: bsd |
510 | # c-basic-offset: 4 |
511 | # indent-tabs-mode: nil |
512 | # End: |
513 | # vim: expandtab shiftwidth=4: |