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 | |
808cb88e |
43 | $VERSION = "0.79_02"; |
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 | |
102 | =head1 METHODS |
103 | |
104 | =head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) |
105 | |
106 | C<_init> creates a new CPANPLUS::Internals object. |
107 | |
108 | You have to pass it a valid C<CPANPLUS::Configure> object. |
109 | |
110 | Returns 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 | |
219 | Flushes the designated caches from the C<CPANPLUS> object. |
220 | |
221 | Returns true on success, false if one or more caches could not be |
222 | be 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 | |
288 | Registers a callback for later use by the internal libraries. |
289 | |
290 | Here is a list of the currently used callbacks: |
291 | |
292 | =over 4 |
293 | |
294 | =item install_prerequisite |
295 | |
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. |
299 | |
300 | =item send_test_report |
301 | |
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. |
305 | |
306 | =item munge_test_report |
307 | |
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. |
311 | |
312 | =item edit_test_report |
313 | |
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 |
317 | to 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 | |
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}>. |
384 | |
385 | Returns true on success, false on failure. |
386 | |
387 | =cut |
388 | |
389 | sub _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 | |
417 | Return the id of the last object stored. |
418 | |
419 | =head2 $id = CPANPLUS::Internals->_store_id( $internals ) |
420 | |
421 | Store this object; return its id. |
422 | |
423 | =head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) |
424 | |
425 | Retrieve an object based on its ID -- return false on error. |
426 | |
427 | =head2 CPANPLUS::Internals->_remove_id( $ID ) |
428 | |
429 | Remove the object marked by $ID from storage. |
430 | |
431 | =head2 @objs = CPANPLUS::Internals->_return_all_objects |
432 | |
433 | Return 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 | |
482 | 1; |
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: |