File Coverage

lib/CPANPLUS/Internals.pm

Criterion	Covered	Total	%
statement	130	138	94.2
branch	33	48	68.8
condition	2	5	40.0
subroutine	29	29	100.0
pod			n/a
total	194	220	88.2

line	stmt	bran	cond	sub	time	code
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	15			15	421	use 5.006001;
	15				236
	15				175
6
7	15			15	301	use strict;
	15				141
	15				223
8	15			15	227	use Config;
	15				140
	15				372
9
10
11	15			15	275	use CPANPLUS::Error;
	15				139
	15				461
12
13	15			15	5998	use CPANPLUS::Internals::Source;
	15				282
	15				511
14	15			15	688	use CPANPLUS::Internals::Extract;
	15				349
	15				412
15	15			15	633	use CPANPLUS::Internals::Fetch;
	15				159
	15				586
16	15			15	314	use CPANPLUS::Internals::Utils;
	15				173
	15				308
17	15			15	237	use CPANPLUS::Internals::Constants;
	15				142
	15				276
18	15			15	784	use CPANPLUS::Internals::Search;
	15				183
	15				509
19	15			15	2273	use CPANPLUS::Internals::Report;
	15				157
	15				432
20
21	15			15	339	use Cwd qw[cwd];
	15				146
	15				313
22	15			15	278	use Params::Check qw[check];
	15				147
	15				266
23	15			15	258	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
	15				140
	15				241
24
25	15			15	378	use Object::Accessor;
	15				136
	15				340
26
27
28						local $Params::Check::VERBOSE = 1;
29
30	15			15	252	use vars qw[@ISA $VERSION];
	15				1084
	15				233
31
32						@ISA = qw[
33						CPANPLUS::Internals::Source
34						CPANPLUS::Internals::Extract
35						CPANPLUS::Internals::Fetch
36						CPANPLUS::Internals::Utils
37						CPANPLUS::Internals::Search
38						CPANPLUS::Internals::Report
39						];
40
41						$VERSION = "0.076";
42
43						=pod
44
45						=head1 NAME
46
47						CPANPLUS::Internals
48
49						=head1 SYNOPSIS
50
51						my $internals = CPANPLUS::Internals->_init( _conf => $conf );
52						my $backend = CPANPLUS::Internals->_retrieve_id( $ID );
53
54						=head1 DESCRIPTION
55
56						This module is the guts of CPANPLUS -- it inherits from all other
57						modules in the CPANPLUS::Internals::* namespace, thus defying normal
58						rules of OO programming -- but if you're reading this, you already
59						know what's going on ;)
60
61						Please read the C<CPANPLUS::Backend> documentation for the normal API.
62
63						=head1 ACCESSORS
64
65						=over 4
66
67						=item _conf
68
69						Get/set the configure object
70
71						=item _id
72
73						Get/set the id
74
75						=item _lib
76
77						Get/set the current @INC path -- @INC is reset to this after each
78						install.
79
80						=item _perl5lib
81
82						Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB}
83						is reset to this after each install.
84
85						=cut
86
87						### autogenerate accessors ###
88						for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status
89						_callbacks]
90						) {
91	15			15	248	no strict 'refs';
	15				132
	15				394
92						*{__PACKAGE__."::$key"} = sub {
93	1347	100		1347	52000	$_[0]->{$key} = $_[1] if @_ > 1;
94	1347				51656	return $_[0]->{$key};
95						}
96						}
97
98						=pod
99
100						=head1 METHODS
101
102						=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
103
104						C<_init> creates a new CPANPLUS::Internals object.
105
106						You have to pass it a valid C<CPANPLUS::Configure> object.
107
108						Returns the object on success, or dies on failure.
109
110						=cut
111						{ ### NOTE:
112						### if extra callbacks are added, don't forget to update the
113						### 02-internals.t test script with them!
114						my $callback_map = {
115						### name default value
116						install_prerequisite => 1, # install prereqs when 'ask' is set?
117						edit_test_report => 0, # edit the prepared test report?
118						send_test_report => 1, # send the test report?
119						# munge the test report
120						munge_test_report => sub { return $_[1] },
121						# filter out unwanted prereqs
122						filter_prereqs => sub { return $_[1] },
123						};
124
125						my $status = Object::Accessor->new;
126						$status->mk_accessors(qw[pending_prereqs]);
127
128						my $callback = Object::Accessor->new;
129						$callback->mk_accessors(keys %$callback_map);
130
131						my $conf;
132						my $Tmpl = {
133						_conf => { required => 1, store => \$conf,
134						allow => IS_CONFOBJ },
135						_id => { default => '', no_override => 1 },
136						_lib => { default => [ @INC ], no_override => 1 },
137						_perl5lib => { default => $ENV{'PERL5LIB'}, no_override => 1 },
138						_authortree => { default => '', no_override => 1 },
139						_modtree => { default => '', no_override => 1 },
140						_hosts => { default => {}, no_override => 1 },
141						_methods => { default => {}, no_override => 1 },
142						_status => { default => '<empty>', no_override => 1 },
143						_callbacks => { default => '<empty>', no_override => 1 },
144						};
145
146						sub _init {
147	12			12	142	my $class = shift;
148	12				145	my %hash = @_;
149
150						### temporary warning until we fix the storing of multiple id's
151						### and their serialization:
152						### probably not going to happen --kane
153	12	50			253	if( my $id = $class->_last_id ) {
154						# make it a singleton.
155	0				0	warn loc(q[%1 currently only supports one %2 object per ] .
156						q[running program], 'CPANPLUS', $class);
157
158	0				0	return $class->_retrieve_id( $id );
159						}
160
161	12	50			217	my $args = check($Tmpl, \%hash)
162						or die loc(qq[Could not initialize '%1' object], $class);
163
164	12				1187	bless $args, $class;
165
166	12				299	$args->{'_id'} = $args->_inc_id;
167	12				175	$args->{'_status'} = $status;
168	12				117	$args->{'_callbacks'} = $callback;
169
170						### initialize callbacks to default state ###
171	12				184	for my $name ( $callback->ls_accessors ) {
172	60	100			6494	my $rv = ref $callback_map->{$name} ? 'sub return value' :
		100
173						$callback_map->{$name} ? 'true' : 'false';
174
175						$args->_callbacks->$name(
176	8			8	264	sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
177						$name, $rv), $args->_conf->get_conf('debug'));
178	8	100			551	return ref $callback_map->{$name}
179						? $callback_map->{$name}->( @_ )
180						: $callback_map->{$name};
181						}
182	60				1123	);
183						}
184
185						### initalize it as an empty hashref ###
186	12				566	$args->_status->pending_prereqs( {} );
187
188						### allow for dirs to be added to @INC at runtime,
189						### rather then compile time
190	12				242	push @INC, @{$conf->get_conf('lib')};
	12				3312
191
192						### add any possible new dirs ###
193	12				561	$args->_lib( [@INC] );
194
195	12	50			184	$conf->_set_build( startdir => cwd() ),
196						or error( loc("couldn't locate current dir!") );
197
198	12	50			1180	$ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
199
200	12				2825	my $id = $args->_store_id( $args );
201
202	12	50			502	unless ( $id == $args->_id ) {
203	0				0	error( loc("IDs do not match: %1 != %2. Storage failed!",
204						$id, $args->_id) );
205						}
206
207	12				4349	return $args;
208						}
209
210						=pod
211
212						=head2 $bool = $internals->_flush( list => \@caches )
213
214						Flushes the designated caches from the C<CPANPLUS> object.
215
216						Returns true on success, false if one or more caches could not be
217						be flushed.
218
219						=cut
220
221						sub _flush {
222	8			8	110	my $self = shift;
223	8				161	my %hash = @_;
224
225	8				87	my $aref;
226	8				309	my $tmpl = {
227						list => { required => 1, default => [],
228						strict_type => 1, store => \$aref },
229						};
230
231	8	50			151	my $args = check( $tmpl, \%hash ) or return;
232
233	8				97	my $flag = 0;
234	8				101	for my $what (@$aref) {
235	14				196	my $cache = '_' . $what;
236
237						### set the include paths back to their original ###
238	14	100			2547	if( $what eq 'lib' ) {
		100
		100
		100
239	4		50		226	$ENV{PERL5LIB} = $self->_perl5lib \|\| '';
240	4				39	@INC = @{$self->_lib};
	4				72
241
242						### give all modules a new status object -- this is slightly
243						### costly, but the best way to make sure all statusses are
244						### forgotten --kane
245						} elsif ( $what eq 'modules' ) {
246	2				51	for my $modobj ( values %{$self->module_tree} ) {
	2				118
247	18				271	$modobj->_flush;
248						}
249
250						### blow away the methods cache... currently, that's only
251						### File::Fetch's method fail list
252						} elsif ( $what eq 'methods' ) {
253
254						### still fucking p4 :( ###
255	2				88	$File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
256
257						### blow away the m::l::c cache, so modules can be (re)loaded
258						### again if they become available
259						} elsif ( $what eq 'load' ) {
260	3				576	undef $Module::Load::Conditional::CACHE;
261
262						} else {
263	3	50	33		58	unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
264	0				0	error( loc( "No such cache: '%1'", $what ) );
265	0				0	$flag++;
266	0				0	next;
267						} else {
268	3				160	$self->$cache( {} );
269						}
270						}
271						}
272	8				257	return !$flag;
273						}
274
275						### NOTE:
276						### if extra callbacks are added, don't forget to update the
277						### 02-internals.t test script with them!
278
279						=pod
280
281						=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
282
283						Registers a callback for later use by the internal libraries.
284
285						Here is a list of the currently used callbacks:
286
287						=over 4
288
289						=item install_prerequisite
290
291						Is called when the user wants to be C<asked> about what to do with
292						prerequisites. Should return a boolean indicating true to install
293						the prerequisite and false to skip it.
294
295						=item send_test_report
296
297						Is called when the user should be prompted if he wishes to send the
298						test report. Should return a boolean indicating true to send the
299						test report and false to skip it.
300
301						=item munge_test_report
302
303						Is called when the test report message has been composed, giving
304						the user a chance to programatically alter it. Should return the
305						(munged) message to be sent.
306
307						=item edit_test_report
308
309						Is called when the user should be prompted to edit test reports
310						about to be sent out by Test::Reporter. Should return a boolean
311						indicating true to edit the test report in an editor and false
312						to skip it.
313
314						=back
315
316						=cut
317
318						sub _register_callback {
319	7	50		7	880	my $self = shift or return;
320	7				237	my %hash = @_;
321
322	7				164	my ($name,$code);
323	7				253	my $tmpl = {
324						name => { required => 1, store => \$name,
325						allow => [$callback->ls_accessors] },
326						code => { required => 1, allow => IS_CODEREF,
327						store => \$code },
328						};
329
330	7	50			984	check( $tmpl, \%hash ) or return;
331
332	7	50			202	$self->_callbacks->$name( $code ) or