line |
stmt |
bran |
cond |
sub |
pod |
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
|
20
|
|
|
20
|
|
530
|
use 5.006001; |
|
20
|
|
|
|
|
77
|
|
6
|
|
|
|
|
|
|
|
7
|
20
|
|
|
20
|
|
103
|
use strict; |
|
20
|
|
|
|
|
35
|
|
|
20
|
|
|
|
|
459
|
|
8
|
20
|
|
|
20
|
|
129
|
use Config; |
|
20
|
|
|
|
|
40
|
|
|
20
|
|
|
|
|
772
|
|
9
|
|
|
|
|
|
|
|
10
|
20
|
|
|
20
|
|
137
|
use CPANPLUS::Error; |
|
20
|
|
|
|
|
37
|
|
|
20
|
|
|
|
|
1182
|
|
11
|
|
|
|
|
|
|
|
12
|
20
|
|
|
20
|
|
7033
|
use CPANPLUS::Selfupdate; |
|
20
|
|
|
|
|
71
|
|
|
20
|
|
|
|
|
976
|
|
13
|
|
|
|
|
|
|
|
14
|
20
|
|
|
20
|
|
8837
|
use CPANPLUS::Internals::Extract; |
|
20
|
|
|
|
|
72
|
|
|
20
|
|
|
|
|
818
|
|
15
|
20
|
|
|
20
|
|
8353
|
use CPANPLUS::Internals::Fetch; |
|
20
|
|
|
|
|
65
|
|
|
20
|
|
|
|
|
897
|
|
16
|
20
|
|
|
20
|
|
166
|
use CPANPLUS::Internals::Utils; |
|
20
|
|
|
|
|
49
|
|
|
20
|
|
|
|
|
600
|
|
17
|
20
|
|
|
20
|
|
122
|
use CPANPLUS::Internals::Constants; |
|
20
|
|
|
|
|
44
|
|
|
20
|
|
|
|
|
6942
|
|
18
|
20
|
|
|
20
|
|
8488
|
use CPANPLUS::Internals::Search; |
|
20
|
|
|
|
|
62
|
|
|
20
|
|
|
|
|
681
|
|
19
|
20
|
|
|
20
|
|
7617
|
use CPANPLUS::Internals::Report; |
|
20
|
|
|
|
|
1889
|
|
|
20
|
|
|
|
|
2410
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
require base; |
22
|
20
|
|
|
20
|
|
207
|
use Cwd qw[cwd]; |
|
20
|
|
|
|
|
42
|
|
|
20
|
|
|
|
|
1235
|
|
23
|
20
|
|
|
20
|
|
131
|
use Module::Load qw[load]; |
|
20
|
|
|
|
|
41
|
|
|
20
|
|
|
|
|
205
|
|
24
|
20
|
|
|
20
|
|
1425
|
use Params::Check qw[check]; |
|
20
|
|
|
|
|
43
|
|
|
20
|
|
|
|
|
899
|
|
25
|
20
|
|
|
20
|
|
126
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
|
20
|
|
|
|
|
41
|
|
|
20
|
|
|
|
|
101
|
|
26
|
20
|
|
|
20
|
|
5567
|
use Module::Load::Conditional qw[can_load]; |
|
20
|
|
|
|
|
43
|
|
|
20
|
|
|
|
|
845
|
|
27
|
|
|
|
|
|
|
|
28
|
20
|
|
|
20
|
|
118
|
use Object::Accessor; |
|
20
|
|
|
|
|
40
|
|
|
20
|
|
|
|
|
673
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
local $Params::Check::VERBOSE = 1; |
31
|
|
|
|
|
|
|
|
32
|
20
|
|
|
20
|
|
103
|
use vars qw[@ISA $VERSION]; |
|
20
|
|
|
|
|
46
|
|
|
20
|
|
|
|
|
1644
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
@ISA = qw[ |
35
|
|
|
|
|
|
|
CPANPLUS::Internals::Extract |
36
|
|
|
|
|
|
|
CPANPLUS::Internals::Fetch |
37
|
|
|
|
|
|
|
CPANPLUS::Internals::Utils |
38
|
|
|
|
|
|
|
CPANPLUS::Internals::Search |
39
|
|
|
|
|
|
|
CPANPLUS::Internals::Report |
40
|
|
|
|
|
|
|
]; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
$VERSION = "0.9914"; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
=pod |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=head1 NAME |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
CPANPLUS::Internals - CPANPLUS internals |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head1 SYNOPSIS |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
my $internals = CPANPLUS::Internals->_init( _conf => $conf ); |
53
|
|
|
|
|
|
|
my $backend = CPANPLUS::Internals->_retrieve_id( $ID ); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 DESCRIPTION |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
This module is the guts of CPANPLUS -- it inherits from all other |
58
|
|
|
|
|
|
|
modules in the CPANPLUS::Internals::* namespace, thus defying normal |
59
|
|
|
|
|
|
|
rules of OO programming -- but if you're reading this, you already |
60
|
|
|
|
|
|
|
know what's going on ;) |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
Please read the C documentation for the normal API. |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head1 ACCESSORS |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=over 4 |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=item _conf |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
Get/set the configure object |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=item _id |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
Get/set the id |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=cut |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
### autogenerate accessors ### |
79
|
|
|
|
|
|
|
for my $key ( qw[_conf _id _modules _hosts _methods _status _path |
80
|
|
|
|
|
|
|
_callbacks _selfupdate _mtree _atree] |
81
|
|
|
|
|
|
|
) { |
82
|
20
|
|
|
20
|
|
128
|
no strict 'refs'; |
|
20
|
|
|
|
|
49
|
|
|
20
|
|
|
|
|
39189
|
|
83
|
|
|
|
|
|
|
*{__PACKAGE__."::$key"} = sub { |
84
|
9647
|
100
|
|
9647
|
|
43078
|
$_[0]->{$key} = $_[1] if @_ > 1; |
85
|
9647
|
|
|
|
|
41864
|
return $_[0]->{$key}; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=pod |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
=back |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=head1 METHODS |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
C<_init> creates a new CPANPLUS::Internals object. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
You have to pass it a valid C object. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
Returns the object on success, or dies on failure. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=cut |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
{ ### NOTE: |
106
|
|
|
|
|
|
|
### if extra callbacks are added, don't forget to update the |
107
|
|
|
|
|
|
|
### 02-internals.t test script with them! |
108
|
|
|
|
|
|
|
my $callback_map = { |
109
|
|
|
|
|
|
|
### name default value |
110
|
|
|
|
|
|
|
install_prerequisite => 1, # install prereqs when 'ask' is set? |
111
|
|
|
|
|
|
|
edit_test_report => 0, # edit the prepared test report? |
112
|
|
|
|
|
|
|
send_test_report => 1, # send the test report? |
113
|
|
|
|
|
|
|
# munge the test report |
114
|
|
|
|
|
|
|
munge_test_report => sub { return $_[1] }, |
115
|
|
|
|
|
|
|
# filter out unwanted prereqs |
116
|
|
|
|
|
|
|
filter_prereqs => sub { return $_[1] }, |
117
|
|
|
|
|
|
|
# continue if 'make test' fails? |
118
|
|
|
|
|
|
|
proceed_on_test_failure => sub { return 0 }, |
119
|
|
|
|
|
|
|
munge_dist_metafile => sub { return $_[1] }, |
120
|
|
|
|
|
|
|
}; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
my $status = Object::Accessor->new; |
123
|
|
|
|
|
|
|
$status->mk_accessors(qw[pending_prereqs]); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
my $callback = Object::Accessor->new; |
126
|
|
|
|
|
|
|
$callback->mk_accessors(keys %$callback_map); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
my $conf; |
129
|
|
|
|
|
|
|
my $Tmpl = { |
130
|
|
|
|
|
|
|
_conf => { required => 1, store => \$conf, |
131
|
|
|
|
|
|
|
allow => IS_CONFOBJ }, |
132
|
|
|
|
|
|
|
_id => { default => '', no_override => 1 }, |
133
|
|
|
|
|
|
|
_authortree => { default => '', no_override => 1 }, |
134
|
|
|
|
|
|
|
_modtree => { default => '', no_override => 1 }, |
135
|
|
|
|
|
|
|
_hosts => { default => {}, no_override => 1 }, |
136
|
|
|
|
|
|
|
_methods => { default => {}, no_override => 1 }, |
137
|
|
|
|
|
|
|
_status => { default => '', no_override => 1 }, |
138
|
|
|
|
|
|
|
_callbacks => { default => '', no_override => 1 }, |
139
|
|
|
|
|
|
|
_path => { default => $ENV{PATH} || '', no_override => 1 }, |
140
|
|
|
|
|
|
|
}; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub _init { |
143
|
14
|
|
|
14
|
|
45
|
my $class = shift; |
144
|
14
|
|
|
|
|
71
|
my %hash = @_; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
### temporary warning until we fix the storing of multiple id's |
147
|
|
|
|
|
|
|
### and their serialization: |
148
|
|
|
|
|
|
|
### probably not going to happen --kane |
149
|
14
|
50
|
|
|
|
126
|
if( my $id = $class->_last_id ) { |
150
|
|
|
|
|
|
|
# make it a singleton. |
151
|
0
|
|
|
|
|
0
|
warn loc(q[%1 currently only supports one %2 object per ] . |
152
|
|
|
|
|
|
|
qq[running program\n], 'CPANPLUS', $class); |
153
|
|
|
|
|
|
|
|
154
|
0
|
|
|
|
|
0
|
return $class->_retrieve_id( $id ); |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
14
|
50
|
|
|
|
90
|
my $args = check($Tmpl, \%hash) |
158
|
|
|
|
|
|
|
or die loc(qq[Could not initialize '%1' object], $class); |
159
|
|
|
|
|
|
|
|
160
|
14
|
|
|
|
|
354
|
bless $args, $class; |
161
|
|
|
|
|
|
|
|
162
|
14
|
|
|
|
|
121
|
$args->{'_id'} = $args->_inc_id; |
163
|
14
|
|
|
|
|
47
|
$args->{'_status'} = $status; |
164
|
14
|
|
|
|
|
39
|
$args->{'_callbacks'} = $callback; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
### initialize callbacks to default state ### |
167
|
14
|
|
|
|
|
67
|
for my $name ( $callback->ls_accessors ) { |
168
|
|
|
|
|
|
|
my $rv = ref $callback_map->{$name} ? 'sub return value' : |
169
|
98
|
100
|
|
|
|
8196
|
$callback_map->{$name} ? 'true' : 'false'; |
|
|
100
|
|
|
|
|
|
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
$args->_callbacks->$name( |
172
|
15
|
|
|
15
|
|
1692
|
sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'", |
173
|
|
|
|
|
|
|
$name, $rv), $args->_conf->get_conf('debug')); |
174
|
|
|
|
|
|
|
return ref $callback_map->{$name} |
175
|
|
|
|
|
|
|
? $callback_map->{$name}->( @_ ) |
176
|
15
|
100
|
|
|
|
285
|
: $callback_map->{$name}; |
177
|
|
|
|
|
|
|
} |
178
|
98
|
|
|
|
|
354
|
); |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
### create a selfupdate object |
182
|
14
|
|
|
|
|
1359
|
$args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) ); |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
### initialize it as an empty hashref ### |
185
|
14
|
|
|
|
|
98
|
$args->_status->pending_prereqs( {} ); |
186
|
|
|
|
|
|
|
|
187
|
14
|
50
|
|
|
|
90030
|
$conf->_set_build( startdir => cwd() ), |
188
|
|
|
|
|
|
|
or error( loc("couldn't locate current dir!") ); |
189
|
|
|
|
|
|
|
|
190
|
14
|
50
|
|
|
|
370
|
$ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive'); |
191
|
|
|
|
|
|
|
|
192
|
14
|
|
|
|
|
599
|
my $id = $args->_store_id( $args ); |
193
|
|
|
|
|
|
|
|
194
|
14
|
50
|
|
|
|
160
|
unless ( $id == $args->_id ) { |
195
|
0
|
|
|
|
|
0
|
error( loc("IDs do not match: %1 != %2. Storage failed!", |
196
|
|
|
|
|
|
|
$id, $args->_id) ); |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
### different source engines available now, so set them here |
200
|
14
|
|
50
|
|
|
116
|
{ my $store = $conf->get_conf( 'source_engine' ) |
|
14
|
|
|
|
|
230
|
|
201
|
|
|
|
|
|
|
|| DEFAULT_SOURCE_ENGINE; |
202
|
|
|
|
|
|
|
|
203
|
14
|
50
|
|
|
|
535
|
unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) { |
204
|
0
|
|
|
|
|
0
|
error( loc( "Could not load source engine '%1'", $store ) ); |
205
|
|
|
|
|
|
|
|
206
|
0
|
0
|
|
|
|
0
|
if( $store ne DEFAULT_SOURCE_ENGINE ) { |
207
|
0
|
|
|
|
|
0
|
msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 ); |
208
|
|
|
|
|
|
|
|
209
|
0
|
|
|
|
|
0
|
load DEFAULT_SOURCE_ENGINE; |
210
|
|
|
|
|
|
|
|
211
|
0
|
|
|
|
|
0
|
base->import( DEFAULT_SOURCE_ENGINE ); |
212
|
|
|
|
|
|
|
} else { |
213
|
0
|
|
|
|
|
0
|
return; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
} else { |
216
|
14
|
|
|
|
|
3033
|
base->import( $store ); |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
14
|
|
|
|
|
289
|
return $args; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
=pod |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
=head2 $bool = $internals->_flush( list => \@caches ) |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
Flushes the designated caches from the C object. |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
Returns true on success, false if one or more caches could not be |
230
|
|
|
|
|
|
|
be flushed. |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=cut |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub _flush { |
235
|
9
|
|
|
9
|
|
668
|
my $self = shift; |
236
|
9
|
|
|
|
|
67
|
my $conf = $self->configure_object; |
237
|
9
|
|
|
|
|
70
|
my %hash = @_; |
238
|
|
|
|
|
|
|
|
239
|
9
|
|
|
|
|
35
|
my $aref; |
240
|
9
|
|
|
|
|
77
|
my $tmpl = { |
241
|
|
|
|
|
|
|
list => { required => 1, default => [], |
242
|
|
|
|
|
|
|
strict_type => 1, store => \$aref }, |
243
|
|
|
|
|
|
|
}; |
244
|
|
|
|
|
|
|
|
245
|
9
|
50
|
|
|
|
57
|
my $args = check( $tmpl, \%hash ) or return; |
246
|
|
|
|
|
|
|
|
247
|
9
|
|
|
|
|
923
|
my $flag = 0; |
248
|
9
|
|
|
|
|
55
|
for my $what (@$aref) { |
249
|
15
|
|
|
|
|
65
|
my $cache = '_' . $what; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
### set the include paths back to their original ### |
252
|
15
|
100
|
|
|
|
132
|
if( $what eq 'lib' ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
253
|
5
|
|
50
|
|
|
38
|
$ENV{PERL5LIB} = $conf->_perl5lib || ''; |
254
|
5
|
|
|
|
|
28
|
@INC = @{$conf->_lib}; |
|
5
|
|
|
|
|
49
|
|
255
|
5
|
|
50
|
|
|
57
|
$ENV{PATH} = $self->_path || ''; |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
### give all modules a new status object -- this is slightly |
258
|
|
|
|
|
|
|
### costly, but the best way to make sure all statuses are |
259
|
|
|
|
|
|
|
### forgotten --kane |
260
|
|
|
|
|
|
|
} elsif ( $what eq 'modules' ) { |
261
|
2
|
|
|
|
|
3
|
for my $modobj ( values %{$self->module_tree} ) { |
|
2
|
|
|
|
|
9
|
|
262
|
|
|
|
|
|
|
|
263
|
20
|
|
|
|
|
55
|
$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 unbelievably p4 :( ### |
271
|
2
|
|
|
|
|
26
|
$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
|
3
|
|
|
|
|
132
|
undef $Module::Load::Conditional::CACHE; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
} else { |
279
|
3
|
50
|
33
|
|
|
39
|
unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) { |
280
|
0
|
|
|
|
|
0
|
error( loc( "No such cache: '%1'", $what ) ); |
281
|
0
|
|
|
|
|
0
|
$flag++; |
282
|
0
|
|
|
|
|
0
|
next; |
283
|
|
|
|
|
|
|
} else { |
284
|
3
|
|
|
|
|
28
|
$self->$cache( {} ); |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
} |
288
|
9
|
|
|
|
|
103
|
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 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 programmatically 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
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
=item munge_dist_metafile |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
Is called when the C metafile is created, like |
339
|
|
|
|
|
|
|
C for C, giving the user a chance to |
340
|
|
|
|
|
|
|
programmatically alter it. Should return the (munged) text to be |
341
|
|
|
|
|
|
|
written to the metafile. |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
=back |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
=cut |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub _register_callback { |
348
|
9
|
50
|
|
9
|
|
261
|
my $self = shift or return; |
349
|
9
|
|
|
|
|
59
|
my %hash = @_; |
350
|
|
|
|
|
|
|
|
351
|
9
|
|
|
|
|
35
|
my ($name,$code); |
352
|
9
|
|
|
|
|
61
|
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
|
9
|
50
|
|
|
|
355
|
check( $tmpl, \%hash ) or return; |
360
|
|
|
|
|
|
|
|
361
|
9
|
50
|
|
|
|
384
|
$self->_callbacks->$name( $code ) or return; |
362
|
|
|
|
|
|
|
|
363
|
9
|
|
|
|
|
1110
|
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
|
12
|
|
|
12
|
|
23405
|
my $self = shift; |
415
|
12
|
|
|
|
|
170
|
my %hash = @_; |
416
|
|
|
|
|
|
|
|
417
|
12
|
|
|
|
|
79
|
my $dirs; |
418
|
12
|
|
|
|
|
120
|
my $tmpl = { |
419
|
|
|
|
|
|
|
directories => { required => 1, default => [], store => \$dirs, |
420
|
|
|
|
|
|
|
strict_type => 1 }, |
421
|
|
|
|
|
|
|
}; |
422
|
|
|
|
|
|
|
|
423
|
12
|
50
|
|
|
|
98
|
check( $tmpl, \%hash ) or return; |
424
|
|
|
|
|
|
|
|
425
|
12
|
|
|
|
|
1754
|
my $s = $Config{'path_sep'}; |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
### only add if it's not added yet |
428
|
12
|
|
|
|
|
122
|
for my $lib (@$dirs) { |
429
|
32
|
100
|
|
|
|
172
|
unshift @INC, $lib unless grep { $_ eq $lib } @INC; |
|
504
|
|
|
|
|
1236
|
|
430
|
|
|
|
|
|
|
# |
431
|
|
|
|
|
|
|
### it will be complaining if $ENV{PERL5LIB] is not defined (yet). |
432
|
32
|
|
|
|
|
184
|
local $^W; |
433
|
|
|
|
|
|
|
$ENV{'PERL5LIB'} .= $s . $lib |
434
|
32
|
100
|
|
|
|
1800
|
unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
12
|
|
|
|
|
152
|
return 1; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
=pod |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
=head2 $bool = $internals->_add_to_path( directories => \@dirs ) |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
Adds a list of directories to the PATH, but only if they actually |
445
|
|
|
|
|
|
|
contain anything. |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
Returns true on success, false on failure. |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
=cut |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
sub _add_to_path { |
452
|
10
|
|
|
10
|
|
57
|
my $self = shift; |
453
|
10
|
|
|
|
|
74
|
my %hash = @_; |
454
|
|
|
|
|
|
|
|
455
|
10
|
|
|
|
|
42
|
my $dirs; |
456
|
10
|
|
|
|
|
89
|
my $tmpl = { |
457
|
|
|
|
|
|
|
directories => { required => 1, default => [], store => \$dirs, |
458
|
|
|
|
|
|
|
strict_type => 1 }, |
459
|
|
|
|
|
|
|
}; |
460
|
|
|
|
|
|
|
|
461
|
10
|
50
|
|
|
|
81
|
check( $tmpl, \%hash ) or return; |
462
|
|
|
|
|
|
|
|
463
|
10
|
|
|
|
|
947
|
my $s = $Config{'path_sep'}; |
464
|
|
|
|
|
|
|
|
465
|
10
|
|
|
|
|
151
|
require File::Glob; |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
### only add if it's not added yet |
468
|
10
|
|
|
|
|
87
|
for my $dir (@$dirs) { |
469
|
20
|
|
|
|
|
495
|
$dir =~ s![\\/]*$!!g; |
470
|
20
|
100
|
|
|
|
792
|
next if $ENV{PATH} =~ qr|\Q$dir\E|; |
471
|
16
|
100
|
|
|
|
485
|
next unless -d $dir; |
472
|
12
|
100
|
|
|
|
1260
|
next unless File::Glob::bsd_glob( $dir . q{/*} ); |
473
|
4
|
|
|
|
|
131
|
$ENV{PATH} = join $s, $dir, $ENV{PATH}; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
10
|
|
|
|
|
147
|
return 1; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=pod |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
=head2 $id = CPANPLUS::Internals->_last_id |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
Return the id of the last object stored. |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
=head2 $id = CPANPLUS::Internals->_store_id( $internals ) |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
Store this object; return its id. |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
Retrieve an object based on its ID -- return false on error. |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
=head2 CPANPLUS::Internals->_remove_id( $ID ) |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
Remove the object marked by $ID from storage. |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
=head2 @objs = CPANPLUS::Internals->_return_all_objects |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
Return all stored objects. |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=cut |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
### code for storing multiple objects |
505
|
|
|
|
|
|
|
### -- although we only support one right now |
506
|
|
|
|
|
|
|
### XXX when support for multiple objects comes, saving source will have |
507
|
|
|
|
|
|
|
### to change |
508
|
|
|
|
|
|
|
{ |
509
|
|
|
|
|
|
|
my $idref = {}; |
510
|
|
|
|
|
|
|
my $count = 0; |
511
|
|
|
|
|
|
|
|
512
|
15
|
|
|
15
|
|
1395
|
sub _inc_id { return ++$count; } |
513
|
|
|
|
|
|
|
|
514
|
278
|
|
|
278
|
|
1995
|
sub _last_id { $count } |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
sub _store_id { |
517
|
15
|
|
|
15
|
|
1925
|
my $self = shift; |
518
|
15
|
50
|
|
|
|
276
|
my $obj = shift or return; |
519
|
|
|
|
|
|
|
|
520
|
15
|
50
|
|
|
|
350
|
unless( IS_INTERNALS_OBJ->($obj) ) { |
521
|
0
|
|
|
|
|
0
|
error( loc("The object you passed has the wrong ref type: '%1'", |
522
|
|
|
|
|
|
|
ref $obj) ); |
523
|
0
|
|
|
|
|
0
|
return; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
15
|
|
|
|
|
384
|
$idref->{ $obj->_id } = $obj; |
527
|
15
|
|
|
|
|
215
|
return $obj->_id; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
sub _retrieve_id { |
531
|
831
|
|
|
831
|
|
2377
|
my $self = shift; |
532
|
831
|
50
|
|
|
|
2931
|
my $id = shift or return; |
533
|
|
|
|
|
|
|
|
534
|
831
|
|
|
|
|
2626
|
my $obj = $idref->{$id}; |
535
|
831
|
|
|
|
|
2109
|
return $obj; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
sub _remove_id { |
539
|
1
|
|
|
1
|
|
4
|
my $self = shift; |
540
|
1
|
50
|
|
|
|
5
|
my $id = shift or return; |
541
|
|
|
|
|
|
|
|
542
|
1
|
|
|
|
|
6
|
return delete $idref->{$id}; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
87
|
|
|
87
|
|
492
|
sub _return_all_objects { return values %$idref } |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
1; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# Local variables: |
551
|
|
|
|
|
|
|
# c-indentation-style: bsd |
552
|
|
|
|
|
|
|
# c-basic-offset: 4 |
553
|
|
|
|
|
|
|
# indent-tabs-mode: nil |
554
|
|
|
|
|
|
|
# End: |
555
|
|
|
|
|
|
|
# vim: expandtab shiftwidth=4: |