File Coverage

blib/lib/PAR/Dist/FromPPD.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


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__