line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PAR::Dist::FromPPD; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
28779
|
use 5.006; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
35
|
|
4
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
49
|
|
5
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
50
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
8
|
|
|
|
|
|
|
|
9
|
1
|
|
|
1
|
|
1167
|
use PAR::Dist; |
|
1
|
|
|
|
|
8529
|
|
|
1
|
|
|
|
|
101
|
|
10
|
1
|
|
|
1
|
|
892
|
use LWP::Simple (); |
|
1
|
|
|
|
|
80330
|
|
|
1
|
|
|
|
|
25
|
|
11
|
1
|
|
|
1
|
|
409
|
use XML::Parser; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
use Cwd qw/cwd abs_path/; |
13
|
|
|
|
|
|
|
use File::Copy; |
14
|
|
|
|
|
|
|
use File::Spec; |
15
|
|
|
|
|
|
|
use File::Path; |
16
|
|
|
|
|
|
|
use File::Temp (); |
17
|
|
|
|
|
|
|
use Archive::Tar (); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
require Exporter; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw( |
24
|
|
|
|
|
|
|
ppd_to_par get_ppd_content |
25
|
|
|
|
|
|
|
) ] ); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our @EXPORT = qw( |
30
|
|
|
|
|
|
|
ppd_to_par |
31
|
|
|
|
|
|
|
); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
our $VERBOSE = 0; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub _verbose { |
38
|
|
|
|
|
|
|
$VERBOSE = shift if (@_); |
39
|
|
|
|
|
|
|
return $VERBOSE |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub _diag { |
43
|
|
|
|
|
|
|
my $msg = shift; |
44
|
|
|
|
|
|
|
return unless _verbose(); |
45
|
|
|
|
|
|
|
print $msg ."\n"; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub ppd_to_par { |
49
|
|
|
|
|
|
|
die "Uneven number of arguments to 'ppd_to_par'." if @_ % 2; |
50
|
|
|
|
|
|
|
my %args = @_; |
51
|
|
|
|
|
|
|
my @par_files; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
_verbose($args{'verbose'}); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
if (not defined $args{uri}) { |
56
|
|
|
|
|
|
|
die "You need to specify an URI for the PPD file"; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
my $ppd_uri = $args{uri}; |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
my $outdir = abs_path(defined($args{out}) ? $args{out} : '.'); |
61
|
|
|
|
|
|
|
die "Output path not a directory." if not -d $outdir; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
_diag "Looking for PPD."; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my $ppd_text = get_ppd_content($ppd_uri); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
_diag "Parsing PPD XML."; |
68
|
|
|
|
|
|
|
my $parser = XML::Parser->new(Style => 'Tree'); |
69
|
|
|
|
|
|
|
my $ppd_tree = $parser->parse($ppd_text); |
70
|
|
|
|
|
|
|
die "Parsing PPD XML failed" if not defined $ppd_tree; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
my $ppd_info = _ppd_to_info($ppd_tree); |
73
|
|
|
|
|
|
|
die "Malformed PPD" if not defined $ppd_info; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
_diag "Applying user overrides."; |
76
|
|
|
|
|
|
|
# override parsed data with user specified data |
77
|
|
|
|
|
|
|
my %arg_map = ( |
78
|
|
|
|
|
|
|
distname => 'name', |
79
|
|
|
|
|
|
|
distversion => 'version', |
80
|
|
|
|
|
|
|
); |
81
|
|
|
|
|
|
|
_override_info($ppd_info, \%arg_map, \%args); |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
if (not defined $ppd_info->{name}) { |
84
|
|
|
|
|
|
|
die "Missing distribution name"; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
if (not defined $ppd_info->{version}) { |
87
|
|
|
|
|
|
|
die "Missing distribution version"; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
if (not @{$ppd_info->{implementations}}) { |
90
|
|
|
|
|
|
|
die "No IMPLEMENTATION sections in the distribution"; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Select implementation |
94
|
|
|
|
|
|
|
_diag "Selecting implementation."; |
95
|
|
|
|
|
|
|
my $implem = [@{$ppd_info->{implementations}}]; |
96
|
|
|
|
|
|
|
my $chosen; |
97
|
|
|
|
|
|
|
my $sperl = $args{selectperl}; |
98
|
|
|
|
|
|
|
$sperl = qr/$sperl/ if defined $sperl; |
99
|
|
|
|
|
|
|
my $sarch = $args{selectarch}; |
100
|
|
|
|
|
|
|
$sarch = qr/$sarch/ if defined $sarch; |
101
|
|
|
|
|
|
|
if (not $sarch) { |
102
|
|
|
|
|
|
|
if (not $sperl) { |
103
|
|
|
|
|
|
|
$chosen = $implem->[0]; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
else { |
106
|
|
|
|
|
|
|
# have $sperl not $sarch |
107
|
|
|
|
|
|
|
foreach my $impl (@$implem) { |
108
|
|
|
|
|
|
|
if ($impl->{perl} and $impl->{perl} =~ $sperl) { |
109
|
|
|
|
|
|
|
$chosen = $impl; |
110
|
|
|
|
|
|
|
last; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
$chosen = $implem->[0] if not $chosen; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
else { |
117
|
|
|
|
|
|
|
# have $sarch |
118
|
|
|
|
|
|
|
if (not $sperl) { |
119
|
|
|
|
|
|
|
foreach my $impl (@$implem) { |
120
|
|
|
|
|
|
|
if ($impl->{arch} and $impl->{arch} =~ $sarch) { |
121
|
|
|
|
|
|
|
$chosen = $impl; |
122
|
|
|
|
|
|
|
last; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
$chosen = $implem->[0] if not $chosen; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
else { |
128
|
|
|
|
|
|
|
# both |
129
|
|
|
|
|
|
|
my @pre; |
130
|
|
|
|
|
|
|
foreach my $impl (@$implem) { |
131
|
|
|
|
|
|
|
if ($impl->{arch} and $impl->{arch} =~ $sarch) { |
132
|
|
|
|
|
|
|
push @pre, $impl; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
if (not @pre) { |
136
|
|
|
|
|
|
|
$chosen = $implem->[0]; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
else { |
139
|
|
|
|
|
|
|
foreach my $impl (@pre) { |
140
|
|
|
|
|
|
|
if ($impl->{perl} and $impl->{perl} =~ $sperl) { |
141
|
|
|
|
|
|
|
$chosen = $impl; |
142
|
|
|
|
|
|
|
last; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
$chosen = $pre[0] if not $chosen; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# apply the rest of the overrides |
151
|
|
|
|
|
|
|
%arg_map = ( |
152
|
|
|
|
|
|
|
arch => [qw(implementations arch)], |
153
|
|
|
|
|
|
|
perlversion => [qw(implementations perl)], |
154
|
|
|
|
|
|
|
); |
155
|
|
|
|
|
|
|
_override_info($ppd_info, \%arg_map, \%args); |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
if (not defined $chosen->{arch}) { |
158
|
|
|
|
|
|
|
die "Architecture name of chosen implementation is undefined" |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
if (not defined $chosen->{perl}) { |
161
|
|
|
|
|
|
|
die "Minimum perl version of chosen implementation is undefined" |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
_diag "Creating temporary directory"; |
165
|
|
|
|
|
|
|
my $tdir = File::Temp::tempdir( CLEANUP => 1 ); |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
_diag "Fetching (or finding) implementation file"; |
168
|
|
|
|
|
|
|
my $impl_file; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
foreach my $uri (@{$chosen->{uri}}) { |
171
|
|
|
|
|
|
|
my $filename = $uri; |
172
|
|
|
|
|
|
|
$filename =~ s/^.*(?:\/|\\|:)([^\\\/:]+)$/$1/; |
173
|
|
|
|
|
|
|
my $localfile = File::Spec->catfile($tdir, $filename); |
174
|
|
|
|
|
|
|
if ($uri =~ /^(?:ftp|https?):\/\//) { |
175
|
|
|
|
|
|
|
my $code = LWP::Simple::getstore( |
176
|
|
|
|
|
|
|
$uri, $localfile |
177
|
|
|
|
|
|
|
); |
178
|
|
|
|
|
|
|
_diag("URI '$uri' via LWP '$localfile' failed. (LWP, code $code)"), next |
179
|
|
|
|
|
|
|
if not LWP::Simple::is_success($code); |
180
|
|
|
|
|
|
|
$impl_file = $localfile; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
elsif ($uri =~ /^file:\/\// or $uri !~ /^\w+:\/\//) { |
183
|
|
|
|
|
|
|
# local file |
184
|
|
|
|
|
|
|
unless(-f $uri and File::Copy::copy($uri, $localfile)) { |
185
|
|
|
|
|
|
|
_diag "URI '$uri' failed. (local)"; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# try as relative URI |
188
|
|
|
|
|
|
|
my $base = $args{uri}; |
189
|
|
|
|
|
|
|
if ($base =~ /^(?:https?|ftp):\/\//) { |
190
|
|
|
|
|
|
|
$base =~ s!/[^/]+$!/$uri!; |
191
|
|
|
|
|
|
|
my $code = LWP::Simple::getstore( |
192
|
|
|
|
|
|
|
$base, $localfile |
193
|
|
|
|
|
|
|
); |
194
|
|
|
|
|
|
|
_diag("URI '$base' via LWP '$localfile' failed. (LWP, code $code)"), next |
195
|
|
|
|
|
|
|
if not LWP::Simple::is_success($code); |
196
|
|
|
|
|
|
|
$impl_file = $localfile; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
else { |
199
|
|
|
|
|
|
|
next; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
$impl_file = $localfile; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
else { |
205
|
|
|
|
|
|
|
_diag "Invalid URI '$uri'."; |
206
|
|
|
|
|
|
|
next; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
if (not defined $impl_file) { |
212
|
|
|
|
|
|
|
_diag "All CODEBASEs failed."; |
213
|
|
|
|
|
|
|
File::Path::rmtree([$tdir]); |
214
|
|
|
|
|
|
|
return(); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
_diag "Local file: '$impl_file'"; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
_diag "chdir() to '$tdir'"; |
220
|
|
|
|
|
|
|
my $cwd = Cwd::cwd(); |
221
|
|
|
|
|
|
|
chdir($tdir); |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
_diag "Generating 'blib' stub'"; |
224
|
|
|
|
|
|
|
PAR::Dist::generate_blib_stub( |
225
|
|
|
|
|
|
|
name => $ppd_info->{name}, |
226
|
|
|
|
|
|
|
version => $ppd_info->{version}, |
227
|
|
|
|
|
|
|
suffix => join('-', $chosen->{arch}, $chosen->{perl}), |
228
|
|
|
|
|
|
|
); |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
_diag "Extracting local file."; |
231
|
|
|
|
|
|
|
my ($vol, $path, $file) = File::Spec->splitpath($impl_file); |
232
|
|
|
|
|
|
|
my $tar = Archive::Tar->new($file, 1) |
233
|
|
|
|
|
|
|
or chdir($cwd), die "Could not open .tar(.gz) file"; |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
$tar->extract(); |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
_diag "Building PAR ".$ppd_info->{name}; |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
my $par_file; |
240
|
|
|
|
|
|
|
eval { |
241
|
|
|
|
|
|
|
$par_file = PAR::Dist::blib_to_par( |
242
|
|
|
|
|
|
|
name => $ppd_info->{name}, |
243
|
|
|
|
|
|
|
version => $ppd_info->{version}, |
244
|
|
|
|
|
|
|
suffix => join('-', $chosen->{arch}, $chosen->{perl}).'.par', |
245
|
|
|
|
|
|
|
) |
246
|
|
|
|
|
|
|
} or chdir($cwd), die "Failed to build .par: $@"; |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
chdir($cwd), die "Could not find PAR distribution file '$par_file'." |
249
|
|
|
|
|
|
|
if not -f $par_file; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
_diag "Built PAR file '$par_file'."; |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
_diag "Moving distribution file to output directory '$outdir'."; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
unless (File::Copy::move($par_file, $outdir)) { |
256
|
|
|
|
|
|
|
chdir($cwd); |
257
|
|
|
|
|
|
|
die "Could not move file '$par_file' to directory " |
258
|
|
|
|
|
|
|
. "'$outdir'. Reason: $!"; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
$par_file = File::Spec->catfile($outdir, $par_file); |
261
|
|
|
|
|
|
|
if (-f $par_file) { |
262
|
|
|
|
|
|
|
push @par_files, $par_file; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
else { |
265
|
|
|
|
|
|
|
chdir($cwd); |
266
|
|
|
|
|
|
|
die "Lost PAR file along the way. (Ouch!) Expected it at '$par_file'"; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# strip docs |
270
|
|
|
|
|
|
|
if ($args{strip_docs}) { |
271
|
|
|
|
|
|
|
_diag "Removing documentation from the PAR distribution(s)."; |
272
|
|
|
|
|
|
|
PAR::Dist::remove_man($_) for @par_files; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
chdir($cwd); |
276
|
|
|
|
|
|
|
File::Path::rmtree([$tdir]); |
277
|
|
|
|
|
|
|
return(1); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub get_ppd_content { |
283
|
|
|
|
|
|
|
my $ppd_uri = shift; |
284
|
|
|
|
|
|
|
my $ppd_text; |
285
|
|
|
|
|
|
|
if ($ppd_uri =~ /^(?:https?|ftp):\/\//) { |
286
|
|
|
|
|
|
|
# fetch with LWP::Simple |
287
|
|
|
|
|
|
|
_diag "Fetching with LWP::Simple."; |
288
|
|
|
|
|
|
|
$ppd_text = LWP::Simple::get($ppd_uri); |
289
|
|
|
|
|
|
|
die "Could not fetch PPD content from '$ppd_uri' using LWP" |
290
|
|
|
|
|
|
|
if not defined $ppd_text; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
elsif ($ppd_uri =~ /^file:\/\// or $ppd_uri !~ /^\w*:\/\//) { |
293
|
|
|
|
|
|
|
# It's a local file |
294
|
|
|
|
|
|
|
_diag "Reading PPD info from file."; |
295
|
|
|
|
|
|
|
$ppd_uri =~ s/^file:\/\///; |
296
|
|
|
|
|
|
|
open my $fh, '<', $ppd_uri |
297
|
|
|
|
|
|
|
or die "Could not read PPD content from file '$ppd_uri' ($!)"; |
298
|
|
|
|
|
|
|
local $/ = undef; |
299
|
|
|
|
|
|
|
$ppd_text = <$fh>; |
300
|
|
|
|
|
|
|
close $fh; |
301
|
|
|
|
|
|
|
die "Could not read PPD content from file '$ppd_uri' ($!)" |
302
|
|
|
|
|
|
|
if not defined $ppd_text; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
else { |
305
|
|
|
|
|
|
|
# Invalid URI (in our context) |
306
|
|
|
|
|
|
|
die "The PPD URI is invalid: '$ppd_uri'"; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
return $ppd_text; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub _ppd_to_info { |
313
|
|
|
|
|
|
|
my $tree = shift; |
314
|
|
|
|
|
|
|
my $info = { |
315
|
|
|
|
|
|
|
name => undef, |
316
|
|
|
|
|
|
|
version => undef, |
317
|
|
|
|
|
|
|
title => undef, |
318
|
|
|
|
|
|
|
abstract => undef, |
319
|
|
|
|
|
|
|
author => undef, |
320
|
|
|
|
|
|
|
license => undef, |
321
|
|
|
|
|
|
|
deps => [], |
322
|
|
|
|
|
|
|
implementations => [], |
323
|
|
|
|
|
|
|
}; |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
return() if not defined $tree or not ref($tree) eq 'ARRAY'; |
326
|
|
|
|
|
|
|
return() if not $tree->[0] =~ /^softpkg$/i; |
327
|
|
|
|
|
|
|
my $children = $tree->[1]; |
328
|
|
|
|
|
|
|
my $dist_attr = shift @$children; |
329
|
|
|
|
|
|
|
$info->{name} = $dist_attr->{NAME}; |
330
|
|
|
|
|
|
|
$info->{version} = $dist_attr->{VERSION}; |
331
|
|
|
|
|
|
|
return() if not defined $info->{name} or not defined $info->{version}; |
332
|
|
|
|
|
|
|
$info->{version} =~ s/,/./g; |
333
|
|
|
|
|
|
|
$info->{version} =~ s/(?:\.0)+$//; |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
while (@$children) { |
336
|
|
|
|
|
|
|
my $tag = shift @$children; |
337
|
|
|
|
|
|
|
# Skip any direct content |
338
|
|
|
|
|
|
|
shift(@$children), next if $tag eq '0'; |
339
|
|
|
|
|
|
|
if ($tag =~ /^implementation$/i) { |
340
|
|
|
|
|
|
|
my $impl = _parse_implementation(shift @$children); |
341
|
|
|
|
|
|
|
push @{$info->{implementations}}, $impl if defined $impl; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
elsif ($tag =~ /^dependency$/i) { |
344
|
|
|
|
|
|
|
my $dep = _parse_dependency(shift @$children); |
345
|
|
|
|
|
|
|
push @{$info->{deps}}, $dep if defined $dep; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
elsif ($tag =~ /^title$/i) { |
348
|
|
|
|
|
|
|
$info->{title} = shift(@$children)->[2]; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
elsif ($tag =~ /^abstract$/i) { |
351
|
|
|
|
|
|
|
$info->{abstract} = shift(@$children)->[2]; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
elsif ($tag =~ /^author$/i) { |
354
|
|
|
|
|
|
|
$info->{author} = shift(@$children)->[2]; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
elsif ($tag =~ /^license$/i) { |
357
|
|
|
|
|
|
|
$info->{license} = shift(@$children)->[0]{HREF}; |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
else { |
360
|
|
|
|
|
|
|
shift @$children; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
return $info; |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
sub _parse_dependency { |
368
|
|
|
|
|
|
|
my $content_ary = shift; |
369
|
|
|
|
|
|
|
return(); # XXX currently unused and hence not implemented |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
sub _parse_implementation { |
373
|
|
|
|
|
|
|
my $impl_ary = shift; |
374
|
|
|
|
|
|
|
my $impl = { |
375
|
|
|
|
|
|
|
deps => [], |
376
|
|
|
|
|
|
|
os => [], |
377
|
|
|
|
|
|
|
arch => undef, |
378
|
|
|
|
|
|
|
uri => undef, |
379
|
|
|
|
|
|
|
processor => undef, |
380
|
|
|
|
|
|
|
language => undef, |
381
|
|
|
|
|
|
|
osversion => undef, |
382
|
|
|
|
|
|
|
perl => undef, |
383
|
|
|
|
|
|
|
}; |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
my $c = $impl_ary; |
386
|
|
|
|
|
|
|
shift @$c; # skip attributes |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
while (@$c) { |
389
|
|
|
|
|
|
|
my $tag = shift @$c; |
390
|
|
|
|
|
|
|
if ($tag eq '0') { |
391
|
|
|
|
|
|
|
shift @$c; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
elsif ($tag =~ /^language$/i) { |
394
|
|
|
|
|
|
|
$impl->{language} = shift(@$c)->[2]; |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
elsif ($tag =~ /^os$/i) { |
397
|
|
|
|
|
|
|
my $attr = shift(@$c)->[0]; |
398
|
|
|
|
|
|
|
push @{$impl->{os}}, $attr->{VALUE} || $attr->{NAME}; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
elsif ($tag =~ /^osversion$/i) { |
401
|
|
|
|
|
|
|
my $attr = shift(@$c)->[0]; |
402
|
|
|
|
|
|
|
$impl->{osversion} = $attr->{VALUE} || $attr->{NAME}; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
elsif ($tag =~ /^perlcore$/i) { |
405
|
|
|
|
|
|
|
my $attr = shift(@$c)->[0]; |
406
|
|
|
|
|
|
|
$impl->{perl} = $attr->{VERSION}; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
elsif ($tag =~ /^processor$/i) { |
409
|
|
|
|
|
|
|
my $attr = shift(@$c)->[0]; |
410
|
|
|
|
|
|
|
$impl->{processor} = $attr->{VALUE} || $attr->{NAME}; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
elsif ($tag =~ /^architecture$/i) { |
413
|
|
|
|
|
|
|
my $attr = shift(@$c)->[0]; |
414
|
|
|
|
|
|
|
$impl->{arch} = $attr->{VALUE} || $attr->{NAME}; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
elsif ($tag =~ /^codebase$/i) { |
417
|
|
|
|
|
|
|
my $attr = shift(@$c)->[0]; |
418
|
|
|
|
|
|
|
push @{$impl->{uri}}, $attr->{HREF} || $attr->{FILENAME}; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
elsif ($tag =~ /^dependency$/i) { |
421
|
|
|
|
|
|
|
my $dep = _parse_dependency(shift @$c); |
422
|
|
|
|
|
|
|
push @{$impl->{deps}}, $dep if defined $dep; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
else { |
425
|
|
|
|
|
|
|
shift @$c; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
return $impl; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub _override_info { |
433
|
|
|
|
|
|
|
my $info = shift; |
434
|
|
|
|
|
|
|
my $arg_map = shift; |
435
|
|
|
|
|
|
|
my $args = shift; |
436
|
|
|
|
|
|
|
foreach my $arg (keys %$arg_map) { |
437
|
|
|
|
|
|
|
next if not defined $args->{$arg}; |
438
|
|
|
|
|
|
|
my $to = $arg_map->{$arg}; |
439
|
|
|
|
|
|
|
if (ref($to)) { |
440
|
|
|
|
|
|
|
my $ary = $info->{shift(@$to)}; |
441
|
|
|
|
|
|
|
$ary->[$_]{$to->[0]} = $args->{$arg} for 0..$#$ary; |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
else { |
444
|
|
|
|
|
|
|
$info->{$to} = $args->{$arg}; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
1; |
450
|
|
|
|
|
|
|
__END__ |