line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PAR::Repository::Client; |
2
|
|
|
|
|
|
|
|
3
|
9
|
|
|
9
|
|
761571
|
use 5.006; |
|
9
|
|
|
|
|
33
|
|
|
9
|
|
|
|
|
333
|
|
4
|
9
|
|
|
9
|
|
48
|
use strict; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
266
|
|
5
|
9
|
|
|
9
|
|
58
|
use warnings; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
620
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.25'; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# list compatible repository versions |
10
|
|
|
|
|
|
|
# This is a list of numbers of the form "\d+.\d". |
11
|
|
|
|
|
|
|
# Before comparison, any versions are reduced to the |
12
|
|
|
|
|
|
|
# first digit after the period. |
13
|
|
|
|
|
|
|
# Incompatible changes require a change in version in the |
14
|
|
|
|
|
|
|
# first digit after the period. |
15
|
|
|
|
|
|
|
our $Compatible_Versions = { |
16
|
|
|
|
|
|
|
'0.1' => 1, |
17
|
|
|
|
|
|
|
'0.2' => 1, |
18
|
|
|
|
|
|
|
}; |
19
|
|
|
|
|
|
|
|
20
|
9
|
|
|
9
|
|
48
|
use constant MODULES_DBM_FILE => 'modules_dists.dbm'; |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
568
|
|
21
|
9
|
|
|
9
|
|
45
|
use constant SYMLINKS_DBM_FILE => 'symlinks.dbm'; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
467
|
|
22
|
9
|
|
|
9
|
|
133
|
use constant SCRIPTS_DBM_FILE => 'scripts_dists.dbm'; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
364
|
|
23
|
9
|
|
|
9
|
|
46
|
use constant DEPENDENCIES_DBM_FILE => 'dependencies.dbm'; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
383
|
|
24
|
9
|
|
|
9
|
|
44
|
use constant REPOSITORY_INFO_FILE => 'repository_info.yml'; |
|
9
|
|
|
|
|
13
|
|
|
9
|
|
|
|
|
350
|
|
25
|
9
|
|
|
9
|
|
42
|
use constant DBM_CHECKSUMS_FILE => 'dbm_checksums.txt'; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
390
|
|
26
|
|
|
|
|
|
|
|
27
|
9
|
|
|
|
|
10595
|
use base 'PAR::Repository::Query', |
28
|
|
|
|
|
|
|
'PAR::Repository::Client::Util', |
29
|
9
|
|
|
9
|
|
134
|
'PAR::Repository::Client::DBM'; |
|
9
|
|
|
|
|
17
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
require PAR::Repository::Client::HTTP; |
32
|
|
|
|
|
|
|
require PAR::Repository::Client::Local; |
33
|
|
|
|
|
|
|
|
34
|
9
|
|
|
9
|
|
75
|
use Carp qw/croak/; |
|
9
|
|
|
|
|
41
|
|
|
9
|
|
|
|
|
528
|
|
35
|
9
|
|
|
9
|
|
50
|
use File::Spec; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
31445
|
|
36
|
|
|
|
|
|
|
require version; |
37
|
|
|
|
|
|
|
require Config; |
38
|
|
|
|
|
|
|
require PAR::Dist; |
39
|
|
|
|
|
|
|
require DBM::Deep; |
40
|
|
|
|
|
|
|
require Archive::Zip; |
41
|
|
|
|
|
|
|
require File::Temp; |
42
|
|
|
|
|
|
|
require File::Copy; |
43
|
|
|
|
|
|
|
require File::Path; |
44
|
|
|
|
|
|
|
require YAML::Tiny; |
45
|
|
|
|
|
|
|
require PAR; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 NAME |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
PAR::Repository::Client - Access PAR repositories |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=head1 SYNOPSIS |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
use PAR::Repository::Client; |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
my $client = PAR::Repository::Client->new( |
56
|
|
|
|
|
|
|
uri => 'http://foo/repository', |
57
|
|
|
|
|
|
|
http_timeout => 20, # default is 180s |
58
|
|
|
|
|
|
|
); |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# This is happening at run-time, of course: |
61
|
|
|
|
|
|
|
# But calling import from your namespace |
62
|
|
|
|
|
|
|
$client->use_module('Foo::Bar') or die $client->error; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
$client->require_module('Bar::Baz') or die $client->error; |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
$client->run_script('foo', 'arg1', 'arg2') or die $client->error; |
67
|
|
|
|
|
|
|
# should not be reached since we ran 'foo'! |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
=head1 DESCRIPTION |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
This module represents the client for PAR repositories as |
72
|
|
|
|
|
|
|
implemented by the L module. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
Chances are you should be looking at the L module |
75
|
|
|
|
|
|
|
instead. Starting with version 0.950, it supports |
76
|
|
|
|
|
|
|
automatically loading any modules that aren't found on your |
77
|
|
|
|
|
|
|
system from a repository. If you need finer control than that, |
78
|
|
|
|
|
|
|
then this module is the right one to use. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
You can use this module to access repositories in one of |
81
|
|
|
|
|
|
|
two ways: On your local filesystem or via HTTP(S?). The |
82
|
|
|
|
|
|
|
access methods are implemented in |
83
|
|
|
|
|
|
|
L and L. |
84
|
|
|
|
|
|
|
Any common code is in this module. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
L implements the querying interface. The methods |
87
|
|
|
|
|
|
|
described in that module's documentation can be called on |
88
|
|
|
|
|
|
|
C objects. |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=head2 PAR REPOSITORIES |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
For a detailed discussion of the structure of PAR repositories, please |
93
|
|
|
|
|
|
|
have a look at the L distribution. |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
A PAR repository is, well, a repository of F<.par> distributions which |
96
|
|
|
|
|
|
|
contain Perl modules and scripts. You can create F<.par> distributions |
97
|
|
|
|
|
|
|
using the L module or the L module itself. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
If you are unsure what PAR archives are, then have a look |
100
|
|
|
|
|
|
|
at the L section below, which points you at the |
101
|
|
|
|
|
|
|
relevant locations. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=head1 PUBLIC METHODS |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
Following is a list of class and instance methods. |
106
|
|
|
|
|
|
|
(Instance methods until otherwise mentioned.) |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=cut |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=head2 new |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
Creates a new PAR::Repository::Client object. Takes named arguments. |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
Mandatory parameter: |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
I specifies the URI of the repository to use. Initially, http and |
117
|
|
|
|
|
|
|
file URIs will be supported, so you can access a repository locally |
118
|
|
|
|
|
|
|
using C or just with C. |
119
|
|
|
|
|
|
|
HTTP accessible repositories can be specified as C and |
120
|
|
|
|
|
|
|
C. |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Optional parameters: |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
auto_install |
125
|
|
|
|
|
|
|
auto_upgrade |
126
|
|
|
|
|
|
|
static_dependencies |
127
|
|
|
|
|
|
|
cache_dir |
128
|
|
|
|
|
|
|
private_cache_dir |
129
|
|
|
|
|
|
|
architecture |
130
|
|
|
|
|
|
|
perl_version |
131
|
|
|
|
|
|
|
installation_targets |
132
|
|
|
|
|
|
|
http_timeout |
133
|
|
|
|
|
|
|
checksums_timeout |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
If the optional I parameter is set to a true value |
136
|
|
|
|
|
|
|
(default: false), any F<.par> file that is about to be loaded is |
137
|
|
|
|
|
|
|
installed on the local system instead. In this context, please |
138
|
|
|
|
|
|
|
refer to the C method. |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
Similar to I, the I parameter installs |
141
|
|
|
|
|
|
|
a distribution that is about to be loaded - but only if the |
142
|
|
|
|
|
|
|
specified module does not exist on the local system yet or is outdated. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
You cannot set both I and I. If you do, |
145
|
|
|
|
|
|
|
you will get a fatal error. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
If you set the C option to a true value, |
148
|
|
|
|
|
|
|
then the inter-distribution dependency information that is retrieved |
149
|
|
|
|
|
|
|
from the repository will be used to recursively apply your requested |
150
|
|
|
|
|
|
|
action to all dependencies. Essentially, this makes the C |
151
|
|
|
|
|
|
|
method act like a real package manager similar to PPM. |
152
|
|
|
|
|
|
|
In contrast, the default behaviour is to fetch distributions only |
153
|
|
|
|
|
|
|
on demand and potentially recursively. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
In order to control where the modules are installed to, you can |
156
|
|
|
|
|
|
|
use the C method. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
The optional C and C parameters |
159
|
|
|
|
|
|
|
can be used to specify the architecture and perl version that are |
160
|
|
|
|
|
|
|
used to choose the right PAR archives from the repository. |
161
|
|
|
|
|
|
|
Defaults to your running perl, so |
162
|
|
|
|
|
|
|
please read the comments on C and C |
163
|
|
|
|
|
|
|
below before blindly using this. |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
Upon client creation, the repository's version is validated to be |
166
|
|
|
|
|
|
|
compatible with this version of the client. |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
You may specify a C in seconds. |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
The C |
171
|
|
|
|
|
|
|
parameter can be used to set the directory where you want the downloaded |
172
|
|
|
|
|
|
|
files to reside. It defaults to the C<$ENV{PAR_TEMP}> directory or |
173
|
|
|
|
|
|
|
otherwise the C subdirectory of your system's temporary directory. |
174
|
|
|
|
|
|
|
If you set C to something other than the default, the downloaded |
175
|
|
|
|
|
|
|
files should be automatically cached when the HTTP transport layer is |
176
|
|
|
|
|
|
|
used as C only checks for updates. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
By default, each repository client uses its own private cache directory. |
179
|
|
|
|
|
|
|
If you specify C 0>, caching will be mostly |
180
|
|
|
|
|
|
|
disabled. While a C and caching are the default, |
181
|
|
|
|
|
|
|
if you explicitly set a different cache directory with C, |
182
|
|
|
|
|
|
|
you also have to explicitly flag it as a repository-private cache directory |
183
|
|
|
|
|
|
|
(aka re-enable caching) with C 1>. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
By default, it is assumed that the package indices do not change all that |
186
|
|
|
|
|
|
|
often. Therefore, there is a default delay of 30 seconds before their |
187
|
|
|
|
|
|
|
checksums are re-checked as this may require a network request. You can |
188
|
|
|
|
|
|
|
specify in seconds or disable the delay using the C XX> |
189
|
|
|
|
|
|
|
option. |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
=cut |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
sub new { |
194
|
9
|
|
|
9
|
1
|
16362
|
my $proto = shift; |
195
|
9
|
|
33
|
|
|
78
|
my $class = ref($proto) || $proto; |
196
|
|
|
|
|
|
|
|
197
|
9
|
50
|
|
|
|
55
|
croak(__PACKAGE__."->new() takes an even number of arguments.") |
198
|
|
|
|
|
|
|
if @_ % 2; |
199
|
9
|
|
|
|
|
66
|
my %args = @_; |
200
|
|
|
|
|
|
|
|
201
|
9
|
50
|
|
|
|
59
|
croak(__PACKAGE__."->new() needs an 'uri' argument.") |
202
|
|
|
|
|
|
|
if not defined $args{uri}; |
203
|
|
|
|
|
|
|
|
204
|
9
|
|
|
|
|
27
|
my $uri = $args{uri}; |
205
|
|
|
|
|
|
|
|
206
|
9
|
|
|
|
|
22
|
my $obj_class = 'Local'; |
207
|
9
|
50
|
|
|
|
40
|
if ($uri =~ /^https?:\/\//) { |
208
|
0
|
|
|
|
|
0
|
$obj_class = 'HTTP'; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# make sure there is a protocol |
212
|
9
|
50
|
|
|
|
41
|
if ($uri !~ /^\w+:\/\//) { |
213
|
9
|
|
|
|
|
39
|
$uri = "file://$uri"; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
9
|
50
|
33
|
|
|
48
|
if ($args{auto_install} and $args{auto_upgrade}) { |
217
|
0
|
|
|
|
|
0
|
croak(__PACKAGE__."->new(): You can only specify one of 'auto_upgrade' and 'auto_install'"); |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
9
|
100
|
|
|
|
447
|
my $self = bless { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# the repository uri |
222
|
|
|
|
|
|
|
uri => $uri, |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# The last error message |
225
|
|
|
|
|
|
|
error => '', |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# The hash ref of checksums for checking whether we |
228
|
|
|
|
|
|
|
# need to update the dbms |
229
|
|
|
|
|
|
|
checksums => undef, |
230
|
|
|
|
|
|
|
supports_checksums => undef, |
231
|
|
|
|
|
|
|
checksums_timeout => (defined($args{checksums_timeout}) ? $args{checksums_timeout} : 30), |
232
|
|
|
|
|
|
|
last_checksums_refresh => 0, |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# the modules- and scripts dbm storage |
235
|
|
|
|
|
|
|
# both the local temp file for cleanup |
236
|
|
|
|
|
|
|
# and the actual tied hash |
237
|
|
|
|
|
|
|
modules_dbm_temp_file => undef, |
238
|
|
|
|
|
|
|
modules_dbm_hash => undef, |
239
|
|
|
|
|
|
|
scripts_dbm_temp_file => undef, |
240
|
|
|
|
|
|
|
scripts_dbm_hash => undef, |
241
|
|
|
|
|
|
|
dependencies_dbm_temp_file => undef, |
242
|
|
|
|
|
|
|
dependencies_dbm_hash => undef, |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
info => undef, # used for YAML info caching |
245
|
|
|
|
|
|
|
auto_install => $args{auto_install}, |
246
|
|
|
|
|
|
|
auto_upgrade => $args{auto_upgrade}, |
247
|
|
|
|
|
|
|
static_dependencies => $args{static_dependencies}, |
248
|
|
|
|
|
|
|
installation_targets => {}, # see PAR::Dist |
249
|
|
|
|
|
|
|
perl_version => (defined($args{perl_version}) ? $args{perl_version} : $Config::Config{version}), |
250
|
|
|
|
|
|
|
architecture => (defined($args{architecture}) ? $args{architecture} : $Config::Config{archname}), |
251
|
|
|
|
|
|
|
cache_dir => $args{cache_dir}, |
252
|
|
|
|
|
|
|
} => "PAR::Repository::Client::$obj_class"; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# set up the cache dir |
255
|
9
|
50
|
0
|
|
|
163
|
if ( |
|
|
50
|
33
|
|
|
|
|
256
|
|
|
|
|
|
|
not defined $self->{cache_dir} |
257
|
|
|
|
|
|
|
and (not exists $args{private_cache_dir} or $args{private_cache_dir}) # either default or forced |
258
|
|
|
|
|
|
|
) { |
259
|
0
|
|
|
|
|
0
|
$self->{cache_dir} = $self->generate_private_cache_dir(); |
260
|
0
|
|
|
|
|
0
|
$self->{private_cache_dir} = 1; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
elsif (not defined $self->{cache_dir}) { |
263
|
0
|
0
|
|
|
|
0
|
$self->{cache_dir} = defined($ENV{PAR_TEMP}) |
264
|
|
|
|
|
|
|
? $ENV{PAR_TEMP} |
265
|
|
|
|
|
|
|
: $self->generate_private_cache_dir(); # if there is no PAR_TEMP, use a private cache |
266
|
0
|
|
|
|
|
0
|
$self->{private_cache_dir} = defined($ENV{PAR_TEMP}); |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
else { |
269
|
|
|
|
|
|
|
# explicit cache dir |
270
|
9
|
|
|
|
|
33
|
$self->{private_cache_dir} = 0; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
9
|
50
|
|
|
|
306
|
if (!-d $self->{cache_dir}) { |
274
|
0
|
|
|
|
|
0
|
$self->{cleanup_cache_dir} = 1; |
275
|
0
|
|
|
|
|
0
|
File::Path::mkpath($self->{cache_dir}); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# for inter-run caching, calculate the checksums of the local files |
279
|
9
|
|
|
|
|
110
|
$self->{checksums} = $self->_calculate_cache_local_checksums(); |
280
|
|
|
|
|
|
|
|
281
|
9
|
|
|
|
|
65
|
$self->_init(\%args); |
282
|
|
|
|
|
|
|
|
283
|
9
|
100
|
|
|
|
44
|
$self->validate_repository() |
284
|
|
|
|
|
|
|
or croak $self->{error}; |
285
|
|
|
|
|
|
|
|
286
|
8
|
|
|
|
|
81
|
return $self; |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=head2 require_module |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
First argument must be a package name (namespace) to require. |
294
|
|
|
|
|
|
|
The method scans the repository for distributions that |
295
|
|
|
|
|
|
|
contain the specified package. |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
When one or more distributions are found, it determines which |
298
|
|
|
|
|
|
|
distribution to use using the C method. |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
Then, it fetches the prefered F<.par> distribution from the |
301
|
|
|
|
|
|
|
repository and opens it using the L module. Finally, |
302
|
|
|
|
|
|
|
it loads the specified module from the downloaded |
303
|
|
|
|
|
|
|
F<.par> distribution using C. |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
Returns 1 on success, the empty list on failure. In case |
306
|
|
|
|
|
|
|
of failure, an error message can be obtained with the |
307
|
|
|
|
|
|
|
C method. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
=cut |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub require_module { |
312
|
3
|
|
|
3
|
1
|
10
|
my $self = shift; |
313
|
3
|
|
|
|
|
9
|
my $namespace = shift; |
314
|
3
|
|
|
|
|
10
|
$self->{error} = undef; |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# fetch the module, load preferably (fallback => 0) |
317
|
3
|
|
|
|
|
21
|
my $file = $self->get_module($namespace, 0); |
318
|
|
|
|
|
|
|
|
319
|
3
|
|
|
|
|
281
|
eval "require $namespace;"; |
320
|
3
|
100
|
|
|
|
28
|
if ($@) { |
321
|
2
|
|
|
|
|
15
|
$self->{error} = "An error occurred while executing 'require $namespace;'. Error: $@"; |
322
|
2
|
|
|
|
|
19
|
return(); |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
1
|
|
|
|
|
11
|
return 1; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
=head2 use_module |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
Works the same as the C method except that |
332
|
|
|
|
|
|
|
instead of only requiring the specified module, it also |
333
|
|
|
|
|
|
|
calls the C method if it exists. Any arguments to |
334
|
|
|
|
|
|
|
this methods after the package to load are passed to the |
335
|
|
|
|
|
|
|
C call. |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
=cut |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub use_module { |
340
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
341
|
0
|
|
|
|
|
0
|
my $namespace = shift; |
342
|
0
|
|
|
|
|
0
|
my @args = @_; |
343
|
0
|
|
|
|
|
0
|
$self->{error} = undef; |
344
|
|
|
|
|
|
|
|
345
|
0
|
|
|
|
|
0
|
my ($pkg) = caller(); |
346
|
|
|
|
|
|
|
|
347
|
0
|
|
|
|
|
0
|
my $required = $self->require_module($namespace); |
348
|
0
|
0
|
|
|
|
0
|
return() if not $required; # error set by require_module |
349
|
|
|
|
|
|
|
|
350
|
0
|
|
|
|
|
0
|
eval "package $pkg; ${namespace}->import(\@args) if ${namespace}->can('import');"; |
351
|
0
|
0
|
|
|
|
0
|
if ($@) { |
352
|
0
|
|
|
|
|
0
|
$self->{error} = "An error occurred while executing 'package $pkg; ${namespace}->import(\@args);'. Error: $@"; |
353
|
0
|
|
|
|
|
0
|
return(); |
354
|
|
|
|
|
|
|
} |
355
|
0
|
|
|
|
|
0
|
return 1; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=head2 get_module |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
First parameter must be a namespace, second parameter may be |
361
|
|
|
|
|
|
|
a boolean indicating whether the PAR is a fallback-PAR or one |
362
|
|
|
|
|
|
|
to load from preferably. (Defaults to false which means |
363
|
|
|
|
|
|
|
loading preferably.) |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
Searches for a specified namespace in the repository and downloads |
366
|
|
|
|
|
|
|
the corresponding PAR distribution. Automatically loads PAR |
367
|
|
|
|
|
|
|
and appends the downloaded PAR distribution to the list of |
368
|
|
|
|
|
|
|
PARs to load from. If auto-installation or auto-upgrading was |
369
|
|
|
|
|
|
|
enabled, the contents of the PAR distribution will |
370
|
|
|
|
|
|
|
be installed in addition to loading the PAR. |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
Returns the name of the local |
373
|
|
|
|
|
|
|
PAR file. Think of this as C without actually |
374
|
|
|
|
|
|
|
doing a C of the module. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
=cut |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
sub get_module { |
380
|
3
|
|
|
3
|
1
|
6
|
my $self = shift; |
381
|
3
|
|
|
|
|
8
|
my $namespace = shift; |
382
|
3
|
|
|
|
|
7
|
my $fallback = shift; |
383
|
|
|
|
|
|
|
|
384
|
3
|
|
|
|
|
9
|
$self->{error} = undef; |
385
|
|
|
|
|
|
|
|
386
|
3
|
|
|
|
|
7
|
my @local_par_files; |
387
|
3
|
50
|
|
|
|
64
|
if ($self->{auto_install}) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
388
|
0
|
|
|
|
|
0
|
@local_par_files = $self->install_module($namespace); |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
elsif ($self->{auto_upgrade}) { |
391
|
0
|
|
|
|
|
0
|
@local_par_files = $self->upgrade_module($namespace); |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
elsif ($self->{static_dependencies}) { |
394
|
0
|
|
|
|
|
0
|
my $deps = $self->get_module_dependencies($namespace); |
395
|
0
|
0
|
|
|
|
0
|
return() if not ref $deps; |
396
|
|
|
|
|
|
|
|
397
|
0
|
|
|
|
|
0
|
foreach my $dep_dist (@$deps) { |
398
|
0
|
|
|
|
|
0
|
my $local_par_file = $self->_fetch_dist($dep_dist); |
399
|
0
|
0
|
|
|
|
0
|
return() if not defined $local_par_file; |
400
|
0
|
|
|
|
|
0
|
push @local_par_files, $local_par_file; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
else { |
404
|
3
|
|
|
|
|
18
|
my $dist = $self->_module2dist($namespace); |
405
|
3
|
100
|
|
|
|
23
|
return() if not defined $dist; |
406
|
1
|
|
|
|
|
7
|
my $local_par_file = $self->_fetch_dist($dist); |
407
|
1
|
50
|
|
|
|
6
|
return() if not defined $local_par_file; |
408
|
1
|
|
|
|
|
5
|
push @local_par_files, $local_par_file; |
409
|
|
|
|
|
|
|
} |
410
|
1
|
50
|
|
|
|
6
|
return() if not @local_par_files; |
411
|
|
|
|
|
|
|
|
412
|
1
|
50
|
|
|
|
8
|
foreach my $local_par_file ($fallback ? @local_par_files : reverse(@local_par_files)) { |
413
|
1
|
50
|
|
|
|
21
|
PAR->import( { file => $local_par_file, fallback => ($fallback?1:0) } ); |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
1
|
|
|
|
|
46085
|
return shift @local_par_files; # FIXME should this return the full array? |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=head2 install_module |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
Works the same as C but instead of loading the |
423
|
|
|
|
|
|
|
F<.par> file using PAR, it installs its contents using |
424
|
|
|
|
|
|
|
L's C routine. |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
First argument must be the namespace of a module to install. |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
Note that this method always installs the whole F<.par> distribution |
429
|
|
|
|
|
|
|
that contains the newest version of the specified namespace and not |
430
|
|
|
|
|
|
|
only the F<.pm> file from the distribution which contains the |
431
|
|
|
|
|
|
|
specified namespace. |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
Returns the name of the local F<.par> file which was installed or |
434
|
|
|
|
|
|
|
the empty list on failure. |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
=cut |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub install_module { |
439
|
2
|
|
|
2
|
1
|
20
|
my $self = shift; |
440
|
2
|
|
|
|
|
6
|
my $namespace = shift; |
441
|
|
|
|
|
|
|
|
442
|
2
|
|
|
|
|
8
|
$self->{error} = undef; |
443
|
|
|
|
|
|
|
|
444
|
2
|
|
|
|
|
4
|
my @local_par_files; |
445
|
2
|
50
|
|
|
|
13
|
if ($self->{static_dependencies}) { |
446
|
0
|
|
|
|
|
0
|
my $deps = $self->get_module_dependencies($namespace); |
447
|
0
|
0
|
|
|
|
0
|
return() if not ref $deps; |
448
|
|
|
|
|
|
|
|
449
|
0
|
|
|
|
|
0
|
foreach my $dep_dist (@$deps) { |
450
|
0
|
|
|
|
|
0
|
my $local_par_file = $self->_fetch_dist($dep_dist); |
451
|
0
|
0
|
|
|
|
0
|
return() if not defined $local_par_file; |
452
|
0
|
|
|
|
|
0
|
push @local_par_files, $local_par_file; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
else { |
456
|
2
|
|
|
|
|
20
|
push @local_par_files, $self->_fetch_module($namespace); |
457
|
|
|
|
|
|
|
} |
458
|
2
|
50
|
|
|
|
11
|
return() if not @local_par_files; |
459
|
|
|
|
|
|
|
|
460
|
2
|
|
|
|
|
6
|
foreach my $local_par_file (@local_par_files) { |
461
|
2
|
|
|
|
|
12
|
PAR::Dist::install_par( |
462
|
2
|
50
|
|
|
|
5
|
%{$self->installation_targets()}, |
463
|
|
|
|
|
|
|
dist => $local_par_file, |
464
|
|
|
|
|
|
|
) or return (); |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
2
|
|
|
|
|
280630
|
return shift @local_par_files; # FIXME should this return the whole array? |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=head2 upgrade_module |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
Works the same as C but instead of loading the |
474
|
|
|
|
|
|
|
F<.par> file using PAR, it checks whether the local version of |
475
|
|
|
|
|
|
|
the module is current. If it isn't, the distribution containing |
476
|
|
|
|
|
|
|
the newest version of the module is installed using |
477
|
|
|
|
|
|
|
L's C routine. |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
First argument must be the namespace of a module to upgrade. |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
Note that this method always installs the whole F<.par> distribution |
482
|
|
|
|
|
|
|
that contains the newest version of the specified namespace and not |
483
|
|
|
|
|
|
|
only the F<.pm> file from the distribution which contains the |
484
|
|
|
|
|
|
|
specified namespace. |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
Returns the name of the local F<.par> file which was installed or |
487
|
|
|
|
|
|
|
the empty list on failure or if the local version of the module is |
488
|
|
|
|
|
|
|
already current. |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
I This will first try to require a locally installed version |
491
|
|
|
|
|
|
|
of the module. If that succeeds, its version is compared to the |
492
|
|
|
|
|
|
|
highest version in the repository. If an upgrade is necessary, |
493
|
|
|
|
|
|
|
the new module will be installed. If the module hadn't been found |
494
|
|
|
|
|
|
|
locally before the installation, it will be loaded. If it was |
495
|
|
|
|
|
|
|
found locally (and thus loaded), C
|
496
|
|
|
|
|
|
|
YOU GET THE NEW VERSION>. |
497
|
|
|
|
|
|
|
This is because reloading of modules is not a simple issue. |
498
|
|
|
|
|
|
|
If you need this behaviour, you can get it manually using L |
499
|
|
|
|
|
|
|
and another require. |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=cut |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
sub upgrade_module { |
504
|
2
|
|
|
2
|
1
|
29
|
my $self = shift; |
505
|
2
|
|
|
|
|
6
|
my $namespace = shift; |
506
|
|
|
|
|
|
|
|
507
|
2
|
|
|
|
|
6
|
$self->{error} = undef; |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
# get local version |
510
|
2
|
|
|
|
|
5
|
my $local_version; |
511
|
2
|
|
|
|
|
6
|
local @PAR::PriorityRepositoryObjects = (); # do not load from remote! |
512
|
2
|
|
|
|
|
8
|
local @PAR::RepositoryObjects = (); # do not load from remote! |
513
|
2
|
|
|
|
|
5
|
local @PAR::UpgradeRepositoryObjects = (); |
514
|
2
|
|
|
|
|
268
|
eval "require ${namespace}; \$local_version = ${namespace}->VERSION;"; |
515
|
2
|
50
|
33
|
|
|
20
|
$local_version = version->new($local_version) if defined($local_version) and not eval {$local_version->isa('version')}; |
|
2
|
|
|
|
|
40
|
|
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# no local version found. Install from repo |
518
|
2
|
50
|
|
|
|
9
|
if (not defined $local_version) { |
519
|
0
|
|
|
|
|
0
|
return $self->install_module($namespace); |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
# The following code is all for determining the newest |
523
|
|
|
|
|
|
|
# version in the repository. |
524
|
2
|
|
|
|
|
15
|
my ($modh) = $self->modules_dbm; |
525
|
2
|
50
|
|
|
|
9
|
if (not defined $modh) { |
526
|
0
|
|
|
|
|
0
|
return(); |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
|
529
|
2
|
|
|
|
|
23
|
my $dists = $modh->{$namespace}; |
530
|
2
|
50
|
|
|
|
2735
|
if (not defined $dists) { |
531
|
0
|
|
|
|
|
0
|
$self->{error} = "Could not find module '$namespace' in the repository."; |
532
|
0
|
|
|
|
|
0
|
return(); |
533
|
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
|
|
535
|
2
|
|
|
|
|
22
|
my $dist = $self->prefered_distribution($namespace, $dists); |
536
|
2
|
50
|
|
|
|
12
|
if (not defined $dist) { |
537
|
0
|
|
|
|
|
0
|
$self->{error} = "PAR: Could not find a distribution for package '$namespace'"; |
538
|
0
|
|
|
|
|
0
|
return(); |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
2
|
|
|
|
|
13
|
my $repo_version = $modh->{$namespace}{$dist}; |
542
|
2
|
50
|
|
|
|
3151
|
$repo_version = version->new($repo_version) if not eval {$repo_version->isa('version')}; |
|
2
|
|
|
|
|
37
|
|
543
|
|
|
|
|
|
|
|
544
|
2
|
100
|
|
|
|
23
|
if ($repo_version > $local_version) { |
545
|
1
|
|
|
|
|
14
|
return $self->install_module($namespace); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
1
|
|
|
|
|
12
|
return(); |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=head2 run_script |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
First parameter must be a script name. |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
Searches for a specified script in the repository and downloads |
557
|
|
|
|
|
|
|
the corresponding PAR distribution. Automatically loads PAR |
558
|
|
|
|
|
|
|
and appends the downloaded PAR distribution to the list of |
559
|
|
|
|
|
|
|
PARs to load from. |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
Then, it runs the script. It does not return unless some error occurrs. |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
If either I or I were specified as |
564
|
|
|
|
|
|
|
parameters to the constructor, the downloaded PAR distribution will |
565
|
|
|
|
|
|
|
be installed regardless of the versions of any previously installed |
566
|
|
|
|
|
|
|
scripts. This differs from the behaviour for mdoules. |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
=cut |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
sub run_script { |
571
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
572
|
0
|
|
|
|
|
0
|
my $script = shift; |
573
|
|
|
|
|
|
|
|
574
|
0
|
|
|
|
|
0
|
my @local_par_files; |
575
|
0
|
0
|
|
|
|
0
|
if ($self->{static_dependencies}) { |
576
|
0
|
|
|
|
|
0
|
my $deps = $self->get_script_dependencies($script); |
577
|
0
|
0
|
|
|
|
0
|
return() if not ref $deps; |
578
|
|
|
|
|
|
|
|
579
|
0
|
|
|
|
|
0
|
foreach my $dep_dist (@$deps) { |
580
|
0
|
|
|
|
|
0
|
my $local_par_file = $self->_fetch_dist($dep_dist); |
581
|
0
|
0
|
|
|
|
0
|
return() if not defined $local_par_file; |
582
|
0
|
|
|
|
|
0
|
push @local_par_files, $local_par_file; |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
else { |
586
|
0
|
|
|
|
|
0
|
my $dist = $self->_script2dist($script); |
587
|
0
|
0
|
|
|
|
0
|
return() unless defined $dist; |
588
|
0
|
|
|
|
|
0
|
my $local_par_file = $self->fetch_par($dist); |
589
|
0
|
0
|
|
|
|
0
|
return() unless defined $local_par_file; |
590
|
0
|
|
|
|
|
0
|
push @local_par_files, $local_par_file; |
591
|
|
|
|
|
|
|
} |
592
|
0
|
0
|
|
|
|
0
|
return() if not @local_par_files; |
593
|
|
|
|
|
|
|
|
594
|
0
|
0
|
|
|
|
0
|
if ($self->{auto_install}) { |
|
|
0
|
|
|
|
|
|
595
|
0
|
|
|
|
|
0
|
foreach my $local_par_file (@local_par_files) { |
596
|
0
|
|
|
|
|
0
|
PAR::Dist::install_par( |
597
|
0
|
0
|
|
|
|
0
|
%{ $self->installation_targets() }, |
598
|
|
|
|
|
|
|
dist => $local_par_file, |
599
|
|
|
|
|
|
|
) or return (); |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
elsif ($self->{auto_upgrade}) { |
603
|
|
|
|
|
|
|
# FIXME This is not the right way to do it! |
604
|
0
|
|
|
|
|
0
|
foreach my $local_par_file (@local_par_files) { |
605
|
0
|
|
|
|
|
0
|
PAR::Dist::install_par( |
606
|
0
|
0
|
|
|
|
0
|
%{ $self->installation_targets() }, |
607
|
|
|
|
|
|
|
dist => $local_par_file, |
608
|
|
|
|
|
|
|
) or return (); |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
|
612
|
0
|
|
|
|
|
0
|
my $script_par = shift @local_par_files; |
613
|
0
|
|
|
|
|
0
|
foreach my $local_par_file (@local_par_files) { |
614
|
0
|
|
|
|
|
0
|
PAR->import( { file => $local_par_file } ); |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
|
617
|
0
|
|
|
|
|
0
|
PAR->import( { file => $script_par, run => $script } ); |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# doesn't happen!? |
620
|
0
|
|
|
|
|
0
|
return 1; |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=head2 get_module_dependencies |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
Given a module name, determines the correct distribution in |
627
|
|
|
|
|
|
|
the repository that supplies the module. Returns a reference |
628
|
|
|
|
|
|
|
to an array containing that distribution and all distributions |
629
|
|
|
|
|
|
|
it depends on. The distribution that contains the given module |
630
|
|
|
|
|
|
|
is the first in the array. |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
Returns the empty list on failure. |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
=cut |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
sub get_module_dependencies { |
637
|
1
|
|
|
1
|
1
|
1516
|
my $self = shift; |
638
|
1
|
|
|
|
|
3
|
my $namespace = shift; |
639
|
1
|
|
|
|
|
11
|
$self->{error} = undef, |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
my $dist = $self->_module2dist($namespace); |
642
|
1
|
50
|
|
|
|
7
|
return() if not defined $dist; |
643
|
|
|
|
|
|
|
|
644
|
1
|
|
|
|
|
9
|
my $deps = $self->_resolve_static_dependencies($dist); |
645
|
1
|
50
|
|
|
|
7
|
return() if not ref $deps; |
646
|
1
|
|
|
|
|
4
|
unshift @$deps, $dist; |
647
|
|
|
|
|
|
|
|
648
|
1
|
|
|
|
|
8
|
return $deps; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
=head2 get_script_dependencies |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
Given a script name, determines the correct distribution in |
655
|
|
|
|
|
|
|
the repository that supplies the script. Returns a reference |
656
|
|
|
|
|
|
|
to an array containing that distribution and all distributions |
657
|
|
|
|
|
|
|
it depends on. The distribution that contains the given script |
658
|
|
|
|
|
|
|
is the first in the array. |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
Returns the empty list on failure. |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
=cut |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
sub get_script_dependencies { |
665
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
666
|
0
|
|
|
|
|
0
|
my $script = shift; |
667
|
0
|
|
|
|
|
0
|
$self->{error} = undef, |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
my $dist = $self->_script2dist($script); |
670
|
0
|
0
|
|
|
|
0
|
return() if not defined $dist; |
671
|
|
|
|
|
|
|
|
672
|
0
|
|
|
|
|
0
|
my $deps = $self->_resolve_static_dependencies($dist); |
673
|
0
|
0
|
|
|
|
0
|
return() if not ref $deps; |
674
|
0
|
|
|
|
|
0
|
unshift @$deps, $dist; |
675
|
|
|
|
|
|
|
|
676
|
0
|
|
|
|
|
0
|
return $deps; |
677
|
|
|
|
|
|
|
} |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
=head2 installation_targets |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
Sets the installation targets for modules and scripts if any arguments are |
683
|
|
|
|
|
|
|
passed. Returns the current setting otherwise. |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
Arguments should be key/value pairs of installation targets |
686
|
|
|
|
|
|
|
as recognized by the C routine in L. |
687
|
|
|
|
|
|
|
The contents of this hash are passed verbatim to every call to |
688
|
|
|
|
|
|
|
C made by this package. |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
In this context, note that aside from the normal i and similar |
691
|
|
|
|
|
|
|
targets, you can also specify a I element starting with |
692
|
|
|
|
|
|
|
C version 0.20. For details, refer to the L manual. |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
Returns a hash reference to a hash containing the installation targets. |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
=cut |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
sub installation_targets { |
699
|
8
|
|
|
8
|
1
|
2270
|
my $self = shift; |
700
|
8
|
100
|
|
|
|
67
|
if (not @_) { |
701
|
5
|
|
|
|
|
11
|
return {%{$self->{installation_targets}}}; |
|
5
|
|
|
|
|
91
|
|
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
3
|
|
|
|
|
99
|
my %args = @_; |
705
|
|
|
|
|
|
|
|
706
|
3
|
|
|
|
|
73
|
$self->{installation_targets} = \%args; |
707
|
3
|
|
|
|
|
10
|
return {%{$self->{installation_targets}}}; |
|
3
|
|
|
|
|
29
|
|
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
=head1 ACCESSORS |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
These methods get or set some attributes of the repository client. |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
=head2 error |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
Returns the last error message if there was an error or |
718
|
|
|
|
|
|
|
the empty list otherwise. |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
=cut |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
sub error { |
723
|
44
|
|
|
44
|
1
|
18535
|
my $self = shift; |
724
|
44
|
|
|
|
|
116
|
my $err = $self->{error}; |
725
|
44
|
100
|
|
|
|
339
|
return(defined($err) ? $err : ()); |
726
|
|
|
|
|
|
|
} |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=head2 perl_version |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
Sets and/or returns the perl version which is used to choose the right |
732
|
|
|
|
|
|
|
C<.par> packages from the repository. Defaults to the currently running |
733
|
|
|
|
|
|
|
perl version (from C<%Config>). |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
You'd better know what you're doing if you plan to set this to something |
736
|
|
|
|
|
|
|
you're not actually running. One valid use is if you use the |
737
|
|
|
|
|
|
|
C possibly in conjunction with |
738
|
|
|
|
|
|
|
L to install into a different perl than the |
739
|
|
|
|
|
|
|
one that's running! |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=cut |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
sub perl_version { |
744
|
22
|
|
|
22
|
1
|
62
|
my $self = shift; |
745
|
22
|
100
|
|
|
|
98
|
$self->{perl_version} = shift @_ if @_; |
746
|
22
|
|
|
|
|
84
|
return $self->{perl_version}; |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
=head2 architecture |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
Sets and/or returns the name of the architecture which is used to choose the right |
753
|
|
|
|
|
|
|
C<.par> packages from the repository. Defaults to the currently running |
754
|
|
|
|
|
|
|
architecture (from C<%Config>). |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
You'd better know what you're doing if you plan to set this to something |
757
|
|
|
|
|
|
|
you're not actually running. One valid use is if you use the |
758
|
|
|
|
|
|
|
C possibly in conjunction with |
759
|
|
|
|
|
|
|
L to install into a different perl than the |
760
|
|
|
|
|
|
|
one that's running! |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
=cut |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
sub architecture { |
765
|
22
|
|
|
22
|
1
|
505
|
my $self = shift; |
766
|
22
|
100
|
|
|
|
75
|
$self->{architecture} = shift @_ if @_; |
767
|
22
|
|
|
|
|
73
|
return $self->{architecture}; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
=head1 OTHER METHODS |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
These methods, while part of the official interface, should need rarely be |
774
|
|
|
|
|
|
|
called by most users. |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
=head2 prefered_distribution |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
This method decides from which distribution a module will be loaded. |
779
|
|
|
|
|
|
|
It returns the corresponding distribution file name. |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
Takes a namespace as first argument followed by a reference |
782
|
|
|
|
|
|
|
to a hash of distribution file names with associated module |
783
|
|
|
|
|
|
|
versions. Example: |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
'Math::Symbolic', |
786
|
|
|
|
|
|
|
{ 'Math-Symbolic-0.502-x86_64-linux-gnu-thread-multi-5.8.7.par' => '0.502', |
787
|
|
|
|
|
|
|
'Math-Symbolic-0.128-any_arch-any_version.par' => '0.128' |
788
|
|
|
|
|
|
|
} |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
This means that the C namespace was found in version C<0.502> |
791
|
|
|
|
|
|
|
and C<0.128> in said distribution files. If you were using linux on an x86_64 |
792
|
|
|
|
|
|
|
computer using perl 5.8.7, this would return the first file name. Otherwise, |
793
|
|
|
|
|
|
|
you would only get version C<0.128>. |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
=cut |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
sub prefered_distribution { |
798
|
17
|
|
|
17
|
1
|
2291
|
my $self = shift; |
799
|
17
|
|
|
|
|
59
|
$self->{error} = undef; |
800
|
17
|
|
|
|
|
35
|
my $ns = shift; |
801
|
17
|
|
|
|
|
57
|
my $dists = shift; |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# potentially faster not to query the db here and rely |
804
|
|
|
|
|
|
|
# on the while/each |
805
|
|
|
|
|
|
|
#return() if not keys %$dists; |
806
|
|
|
|
|
|
|
|
807
|
17
|
|
|
|
|
13479
|
my $this_pver = $self->perl_version; |
808
|
17
|
|
|
|
|
74
|
my $this_arch = $self->architecture; |
809
|
|
|
|
|
|
|
|
810
|
17
|
|
|
|
|
42
|
my @sorted; |
811
|
17
|
|
|
|
|
101
|
while (my ($dist, $ver) = each(%$dists)) { |
812
|
|
|
|
|
|
|
# distfile, version, distname, distver, arch, pver |
813
|
49
|
|
50
|
|
|
89827
|
my $version = version->new($ver||0); |
814
|
49
|
|
|
|
|
290
|
my ($n, $v, $a, $p) = PAR::Dist::parse_dist_name($dist); |
815
|
49
|
50
|
33
|
|
|
5129
|
next if not defined $a or not defined $p; |
816
|
|
|
|
|
|
|
# skip the ones for other archs |
817
|
49
|
100
|
100
|
|
|
365
|
next if $a ne $this_arch and $a ne 'any_arch'; |
818
|
35
|
100
|
100
|
|
|
200
|
next if $p ne $this_pver and $p ne 'any_version'; |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# as a fallback while sorting, prefer arch and pver |
821
|
|
|
|
|
|
|
# specific dists to fallbacks |
822
|
27
|
100
|
|
|
|
116
|
my $order_num = |
|
|
100
|
|
|
|
|
|
823
|
|
|
|
|
|
|
($a eq 'any_arch' ? 2 : 0) |
824
|
|
|
|
|
|
|
+ ($p eq 'any_version' ? 1 : 0); |
825
|
27
|
|
|
|
|
196
|
push @sorted, [$dist, $version, $order_num]; |
826
|
|
|
|
|
|
|
} |
827
|
17
|
100
|
|
|
|
37298
|
return() if not @sorted; |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# sort by version, highest first. |
830
|
22
|
50
|
|
|
|
119
|
@sorted = |
831
|
|
|
|
|
|
|
sort { |
832
|
|
|
|
|
|
|
# sort version |
833
|
15
|
|
|
|
|
60
|
$b->[1] <=> $a->[1] |
834
|
|
|
|
|
|
|
or |
835
|
|
|
|
|
|
|
# specific before any_version before any_arch before any_* |
836
|
|
|
|
|
|
|
$a->[2] <=> $b->[2] |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
@sorted; |
839
|
|
|
|
|
|
|
|
840
|
15
|
|
|
|
|
39
|
my $dist = shift @sorted; |
841
|
15
|
|
|
|
|
147
|
return $dist->[0]; |
842
|
|
|
|
|
|
|
} |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
=head2 validate_repository_version |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
Accesses the repository meta information and validates that it |
848
|
|
|
|
|
|
|
has a compatible version. This is done on object creation, so |
849
|
|
|
|
|
|
|
it should not normally be necessary to call this from user code. |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
Returns a boolean indicating the outcome of the operation. |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
=cut |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
sub validate_repository_version { |
856
|
9
|
|
|
9
|
1
|
23
|
my $self = shift; |
857
|
9
|
|
|
|
|
30
|
$self->{error} = undef; |
858
|
|
|
|
|
|
|
|
859
|
9
|
|
|
|
|
58
|
my $info = $self->_repository_info; |
860
|
9
|
50
|
|
|
|
80
|
if (not defined $info) { |
|
|
50
|
|
|
|
|
|
861
|
0
|
|
|
|
|
0
|
return(); |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
elsif (not exists $info->[0]{repository_version}) { |
864
|
0
|
|
|
|
|
0
|
$self->{error} = "Repository info file ('repository_info.yml') does not contain a version."; |
865
|
0
|
|
|
|
|
0
|
return(); |
866
|
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
# check for compatibility |
869
|
9
|
|
|
|
|
109
|
my $repo_version = $info->[0]{repository_version}; |
870
|
|
|
|
|
|
|
|
871
|
9
|
|
|
|
|
24
|
my $main_repo_version = $repo_version; |
872
|
9
|
|
|
|
|
78
|
$main_repo_version =~ s/^(\d+\.\d).*$/$1/; |
873
|
|
|
|
|
|
|
|
874
|
9
|
50
|
|
|
|
68
|
if ( not exists $PAR::Repository::Client::Compatible_Versions->{$main_repo_version} ) { |
875
|
0
|
|
|
|
|
0
|
$self->{error} = "Repository has an incompatible version (".$info->[0]{repository_version}.")"; |
876
|
0
|
|
|
|
|
0
|
return(); |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
9
|
|
|
|
|
57
|
$repo_version =~ s/_.*$//; # remove dev suffix |
880
|
9
|
100
|
100
|
|
|
100
|
if ($repo_version < 0.18 and $self->{static_dependencies}) { |
881
|
1
|
|
|
|
|
4
|
$self->{error} = "Client has static dependency resolution enabled, but repository does not support that. " |
882
|
|
|
|
|
|
|
."Either upgrade your repository to version 0.18 or greater or disable static dependency " |
883
|
|
|
|
|
|
|
."resolution in the client."; |
884
|
1
|
|
|
|
|
383
|
return(); |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
|
887
|
8
|
|
|
|
|
47
|
return 1; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
# given a module name, find the prefered distribution |
892
|
|
|
|
|
|
|
sub _module2dist { |
893
|
8
|
|
|
8
|
|
18
|
my $self = shift; |
894
|
8
|
|
|
|
|
20
|
my $namespace = shift; |
895
|
|
|
|
|
|
|
|
896
|
8
|
|
|
|
|
19
|
$self->{error} = undef; |
897
|
|
|
|
|
|
|
|
898
|
8
|
|
|
|
|
51
|
my ($modh) = $self->modules_dbm; |
899
|
8
|
50
|
|
|
|
37
|
if (not defined $modh) { |
900
|
0
|
|
|
|
|
0
|
return(); |
901
|
|
|
|
|
|
|
} |
902
|
|
|
|
|
|
|
|
903
|
8
|
100
|
66
|
|
|
99
|
if (not exists $modh->{$namespace} or not defined $modh->{$namespace}) { |
904
|
1
|
|
|
|
|
558
|
$self->{error} = "Could not find module '$namespace' in the repository."; |
905
|
1
|
|
|
|
|
3
|
return(); |
906
|
|
|
|
|
|
|
} |
907
|
|
|
|
|
|
|
|
908
|
7
|
|
|
|
|
25161
|
my $dist = $self->prefered_distribution($namespace, $modh->{$namespace}); |
909
|
7
|
100
|
|
|
|
59
|
if (not defined $dist) { |
910
|
2
|
|
|
|
|
134
|
$self->{error} = "PAR: Could not find a distribution for package '$namespace'"; |
911
|
2
|
|
|
|
|
9
|
return(); |
912
|
|
|
|
|
|
|
} |
913
|
5
|
|
|
|
|
233
|
return $dist; |
914
|
|
|
|
|
|
|
} |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
# resolve a script to its prefered distribution |
918
|
|
|
|
|
|
|
sub _script2dist { |
919
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
920
|
0
|
|
|
|
|
0
|
my $script = shift; |
921
|
|
|
|
|
|
|
|
922
|
0
|
|
|
|
|
0
|
$self->{error} = undef; |
923
|
|
|
|
|
|
|
|
924
|
0
|
|
|
|
|
0
|
my ($scrh) = $self->scripts_dbm; |
925
|
0
|
0
|
|
|
|
0
|
if (not defined $scrh) { |
926
|
0
|
|
|
|
|
0
|
return(); |
927
|
|
|
|
|
|
|
} |
928
|
|
|
|
|
|
|
|
929
|
0
|
|
|
|
|
0
|
my $dists = $scrh->{$script}; |
930
|
0
|
0
|
|
|
|
0
|
if (not defined $dists) { |
931
|
0
|
|
|
|
|
0
|
$self->{error} = "Could not find script '$script' in the repository."; |
932
|
0
|
|
|
|
|
0
|
return(); |
933
|
|
|
|
|
|
|
} |
934
|
0
|
|
|
|
|
0
|
my $dist = $self->prefered_distribution($script, $dists); |
935
|
0
|
0
|
|
|
|
0
|
if (not defined $dist) { |
936
|
0
|
|
|
|
|
0
|
$self->{error} = "PAR: Could not find a distribution for script '$script'"; |
937
|
0
|
|
|
|
|
0
|
return(); |
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
|
940
|
0
|
|
|
|
|
0
|
return $dist; |
941
|
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
# download a distribution |
945
|
|
|
|
|
|
|
sub _fetch_dist { |
946
|
4
|
|
|
4
|
|
10
|
my $self = shift; |
947
|
4
|
|
|
|
|
12
|
my $dist = shift; |
948
|
|
|
|
|
|
|
|
949
|
4
|
|
|
|
|
32
|
my $local_par_file = $self->fetch_par($dist); |
950
|
4
|
50
|
33
|
|
|
96
|
return() if not defined $local_par_file or not -f $local_par_file; |
951
|
|
|
|
|
|
|
|
952
|
4
|
|
|
|
|
21
|
return $local_par_file; |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
# resolve a namespace to a distribution and download it |
957
|
|
|
|
|
|
|
sub _fetch_module { |
958
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
959
|
4
|
|
|
|
|
12
|
my $namespace = shift; |
960
|
|
|
|
|
|
|
|
961
|
4
|
|
|
|
|
44
|
my $dist = $self->_module2dist($namespace); |
962
|
4
|
100
|
|
|
|
25
|
return() unless defined $dist; |
963
|
|
|
|
|
|
|
|
964
|
3
|
|
|
|
|
46
|
return $self->_fetch_dist($dist); |
965
|
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
# resolve a script to a distribution and download it |
969
|
|
|
|
|
|
|
sub _fetch_script { |
970
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
971
|
0
|
|
|
|
|
0
|
my $namespace = shift; |
972
|
|
|
|
|
|
|
|
973
|
0
|
|
|
|
|
0
|
my $dist = $self->_script2dist($namespace); |
974
|
0
|
0
|
|
|
|
0
|
return() unless defined $dist; |
975
|
|
|
|
|
|
|
|
976
|
0
|
|
|
|
|
0
|
return $self->_fetch_dist($dist); |
977
|
|
|
|
|
|
|
} |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
sub DESTROY { |
981
|
10
|
|
|
10
|
|
10460
|
my $self = shift; |
982
|
10
|
|
|
|
|
164
|
$self->close_modules_dbm; |
983
|
10
|
|
|
|
|
117
|
$self->close_scripts_dbm; |
984
|
10
|
|
|
|
|
106
|
$self->close_dependencies_dbm; |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
# attempt to clean up empty cache directories |
987
|
10
|
0
|
33
|
|
|
2242
|
rmdir($self->{cache_dir}) |
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
988
|
|
|
|
|
|
|
if $self->{cleanup_cache_dir} |
989
|
|
|
|
|
|
|
and $self->{private_cache_dir} |
990
|
|
|
|
|
|
|
and defined($self->{cache_dir}) |
991
|
|
|
|
|
|
|
and -d $self->{cache_dir}; |
992
|
|
|
|
|
|
|
} |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
1; |
995
|
|
|
|
|
|
|
__END__ |