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

package PAR::Dist::FromPPD;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.03';

use PAR::Dist;
use LWP::Simple ();
use XML::Parser;
use Cwd qw/cwd abs_path/;
use File::Copy;
use File::Spec;
use File::Path;
use File::Temp ();
use Archive::Tar ();

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
    ppd_to_par get_ppd_content
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
    ppd_to_par
);


our $VERBOSE = 0;


sub _verbose {
    $VERBOSE = shift if (@_);
    return $VERBOSE
}

sub _diag {
    my $msg = shift;
    return unless _verbose();
    print $msg ."\n";
}

sub ppd_to_par {
    die "Uneven number of arguments to 'ppd_to_par'." if @_ % 2;
    my %args = @_;
    my @par_files;

    _verbose($args{'verbose'});

    if (not defined $args{uri}) {
        die "You need to specify an URI for the PPD file";
    }
    my $ppd_uri = $args{uri};

    my $outdir = abs_path(defined($args{out}) ? $args{out} : '.');
    die "Output path not a directory." if not -d $outdir;

    _diag "Looking for PPD.";

    my $ppd_text = get_ppd_content($ppd_uri);

    _diag "Parsing PPD XML.";
    my $parser = XML::Parser->new(Style => 'Tree');
    my $ppd_tree = $parser->parse($ppd_text);
    die "Parsing PPD XML failed" if not defined $ppd_tree;

    my $ppd_info = _ppd_to_info($ppd_tree);
    die "Malformed PPD" if not defined $ppd_info;

    _diag "Applying user overrides.";
    # override parsed data with user specified data
    my %arg_map = (
        distname => 'name',
        distversion => 'version',
    );
    _override_info($ppd_info, \%arg_map, \%args);

    if (not defined $ppd_info->{name}) {
        die "Missing distribution name";
    }
    if (not defined $ppd_info->{version}) {
        die "Missing distribution version";
    }
    if (not @{$ppd_info->{implementations}}) {
        die "No IMPLEMENTATION sections in the distribution";
    }

    # Select implementation
    _diag "Selecting implementation.";
    my $implem = [@{$ppd_info->{implementations}}];
    my $chosen;
    my $sperl = $args{selectperl};
    $sperl = qr/$sperl/ if defined $sperl;
    my $sarch = $args{selectarch};
    $sarch = qr/$sarch/ if defined $sarch;
    if (not $sarch) {
        if (not $sperl) {
            $chosen = $implem->[0];
        }
        else {
            # have $sperl not $sarch
            foreach my $impl (@$implem) {
                if ($impl->{perl} and $impl->{perl} =~ $sperl) {
                    $chosen = $impl;
                    last;
                }
            }
            $chosen = $implem->[0] if not $chosen;
        }
    }
    else {
        # have $sarch
        if (not $sperl) {
            foreach my $impl (@$implem) {
                if ($impl->{arch} and $impl->{arch} =~ $sarch) {
                    $chosen = $impl;
                    last;
                }
            }
            $chosen = $implem->[0] if not $chosen;
        }
        else {
            # both
            my @pre;
            foreach my $impl (@$implem) {
                if ($impl->{arch} and $impl->{arch} =~ $sarch) {
                    push @pre, $impl;
                }
            }
            if (not @pre) {
                $chosen = $implem->[0];
            }
            else {
                foreach my $impl (@pre) {
                    if ($impl->{perl} and $impl->{perl} =~ $sperl) {
                        $chosen = $impl;
                        last;
                    }
                }
                $chosen = $pre[0] if not $chosen;
            }
        }
    }

    # apply the rest of the overrides
    %arg_map = (
        arch => [qw(implementations arch)],
        perlversion => [qw(implementations perl)],
    );
    _override_info($ppd_info, \%arg_map, \%args);

    if (not defined $chosen->{arch}) {
        die "Architecture name of chosen implementation is undefined"
    }
    if (not defined $chosen->{perl}) {
        die "Minimum perl version of chosen implementation is undefined"
    }

    _diag "Creating temporary directory";
    my $tdir = File::Temp::tempdir( CLEANUP => 1 );

    _diag "Fetching (or finding) implementation file";
    my $impl_file;

    foreach my $uri (@{$chosen->{uri}}) {
        my $filename = $uri;
        $filename =~ s/^.*(?:\/|\\|:)([^\\\/:]+)$/$1/;
        my $localfile = File::Spec->catfile($tdir, $filename);
        if ($uri =~ /^(?:ftp|https?):\/\//) {
            my $code = LWP::Simple::getstore(
                $uri, $localfile
            );
            _diag("URI '$uri' via LWP '$localfile' failed. (LWP, code $code)"), next
              if not LWP::Simple::is_success($code);
            $impl_file = $localfile;
        }
        elsif ($uri =~ /^file:\/\// or $uri !~ /^\w+:\/\//) {
            # local file
            unless(-f $uri and File::Copy::copy($uri, $localfile)) {
                _diag "URI '$uri' failed. (local)";

                # try as relative URI
                my $base = $args{uri};
                if ($base =~ /^(?:https?|ftp):\/\//) {
                    $base =~ s!/[^/]+$!/$uri!;
                    my $code = LWP::Simple::getstore(
                        $base, $localfile
                    );
                    _diag("URI '$base' via LWP '$localfile' failed. (LWP, code $code)"), next
                      if not LWP::Simple::is_success($code);
                    $impl_file = $localfile;
                }
                else {
                    next;
                }
            }
            $impl_file = $localfile;
        }
        else {
            _diag "Invalid URI '$uri'.";
            next;
        }
    }


    if (not defined $impl_file) {
        _diag "All CODEBASEs failed.";
        File::Path::rmtree([$tdir]);
        return();
    }

    _diag "Local file: '$impl_file'";

    _diag "chdir() to '$tdir'";
    my $cwd = Cwd::cwd();
    chdir($tdir);

    _diag "Generating 'blib' stub'";
    PAR::Dist::generate_blib_stub(
        name => $ppd_info->{name},
        version => $ppd_info->{version},
        suffix => join('-', $chosen->{arch}, $chosen->{perl}),
    );

    _diag "Extracting local file.";
    my ($vol, $path, $file) = File::Spec->splitpath($impl_file);
    my $tar = Archive::Tar->new($file, 1)
      or chdir($cwd), die "Could not open .tar(.gz) file";

    $tar->extract();

    _diag "Building PAR ".$ppd_info->{name};

    my $par_file;
    eval {
        $par_file = PAR::Dist::blib_to_par(
            name => $ppd_info->{name},
            version => $ppd_info->{version},
            suffix => join('-', $chosen->{arch}, $chosen->{perl}).'.par',
        )
    } or chdir($cwd), die "Failed to build .par: $@";

    chdir($cwd), die "Could not find PAR distribution file '$par_file'."
      if not -f $par_file;

    _diag "Built PAR file '$par_file'.";

    _diag "Moving distribution file to output directory '$outdir'.";

    unless (File::Copy::move($par_file, $outdir)) {
        chdir($cwd);
        die "Could not move file '$par_file' to directory "
              . "'$outdir'. Reason: $!";
    }
   $par_file = File::Spec->catfile($outdir, $par_file);
   if (-f $par_file) {
       push @par_files, $par_file;
   }
   else {
       chdir($cwd);
       die "Lost PAR file along the way. (Ouch!) Expected it at '$par_file'";
   }

    # strip docs
    if ($args{strip_docs}) {
        _diag "Removing documentation from the PAR distribution(s).";
        PAR::Dist::remove_man($_) for @par_files;
    }

    chdir($cwd);
    File::Path::rmtree([$tdir]);
    return(1);
}



sub get_ppd_content {
    my $ppd_uri = shift;
    my $ppd_text;
        if ($ppd_uri =~ /^(?:https?|ftp):\/\//) {
        # fetch with LWP::Simple
        _diag "Fetching with LWP::Simple.";
        $ppd_text = LWP::Simple::get($ppd_uri);
        die "Could not fetch PPD content from '$ppd_uri' using LWP"
          if not defined $ppd_text;
    }
    elsif ($ppd_uri =~ /^file:\/\// or $ppd_uri !~ /^\w*:\/\//) {
        # It's a local file
        _diag "Reading PPD info from file.";
        $ppd_uri =~ s/^file:\/\///;
        open my $fh, '<', $ppd_uri
          or die "Could not read PPD content from file '$ppd_uri' ($!)";
        local $/ = undef;
        $ppd_text = <$fh>;
        close $fh;
        die "Could not read PPD content from file '$ppd_uri' ($!)"
          if not defined $ppd_text;
    }
    else {
        # Invalid URI (in our context)
        die "The PPD URI is invalid: '$ppd_uri'";
    }
    return $ppd_text;
}


sub _ppd_to_info {
    my $tree = shift;
    my $info = {
        name => undef,
        version => undef,
        title => undef,
        abstract => undef,
        author => undef,
        license => undef,
        deps => [],
        implementations => [],
    };

    return() if not defined $tree or not ref($tree) eq 'ARRAY';
    return() if not $tree->[0] =~ /^softpkg$/i;
    my $children = $tree->[1];
    my $dist_attr = shift @$children;
    $info->{name} = $dist_attr->{NAME};
    $info->{version} = $dist_attr->{VERSION};
    return() if not defined $info->{name} or not defined $info->{version};
    $info->{version} =~ s/,/./g;
    $info->{version} =~ s/(?:\.0)+$//;

    while (@$children) {
        my $tag = shift @$children;
        # Skip any direct content
        shift(@$children), next if $tag eq '0';
        if ($tag =~ /^implementation$/i) {
            my $impl = _parse_implementation(shift @$children);
            push @{$info->{implementations}}, $impl if defined $impl;
        }
        elsif ($tag =~ /^dependency$/i) {
            my $dep = _parse_dependency(shift @$children);
            push @{$info->{deps}}, $dep if defined $dep;
        }
        elsif ($tag =~ /^title$/i) {
            $info->{title} = shift(@$children)->[2];
        }
        elsif ($tag =~ /^abstract$/i) {
            $info->{abstract} = shift(@$children)->[2];
        }
        elsif ($tag =~ /^author$/i) {
            $info->{author} = shift(@$children)->[2];
        }
        elsif ($tag =~ /^license$/i) {
            $info->{license} = shift(@$children)->[0]{HREF};
        }
        else {
            shift @$children;
        }
    }
    return $info;
}


sub _parse_dependency {
    my $content_ary = shift;
    return(); # XXX currently unused and hence not implemented
}

sub _parse_implementation {
    my $impl_ary = shift;
    my $impl = {
        deps => [],
        os => [],
        arch => undef,
        uri => undef,
        processor => undef,
        language => undef,
        osversion => undef,
        perl => undef,
    };

    my $c = $impl_ary;
    shift @$c; # skip attributes

    while (@$c) {
        my $tag = shift @$c;
        if ($tag eq '0') {
            shift @$c;
        }
        elsif ($tag =~ /^language$/i) {
            $impl->{language} = shift(@$c)->[2];
        }
        elsif ($tag =~ /^os$/i) {
            my $attr = shift(@$c)->[0];
            push @{$impl->{os}}, $attr->{VALUE} || $attr->{NAME};
        }
        elsif ($tag =~ /^osversion$/i) {
            my $attr = shift(@$c)->[0];
            $impl->{osversion} = $attr->{VALUE} || $attr->{NAME};
        }
        elsif ($tag =~ /^perlcore$/i) {
            my $attr = shift(@$c)->[0];
            $impl->{perl} = $attr->{VERSION};
        }
        elsif ($tag =~ /^processor$/i) {
            my $attr = shift(@$c)->[0];
            $impl->{processor} = $attr->{VALUE} || $attr->{NAME};
        }
        elsif ($tag =~ /^architecture$/i) {
            my $attr = shift(@$c)->[0];
            $impl->{arch} = $attr->{VALUE} || $attr->{NAME};
        }
        elsif ($tag =~ /^codebase$/i) {
            my $attr = shift(@$c)->[0];
            push @{$impl->{uri}}, $attr->{HREF} || $attr->{FILENAME};
        }
        elsif ($tag =~ /^dependency$/i) {
            my $dep = _parse_dependency(shift @$c);
            push @{$impl->{deps}}, $dep if defined $dep;
        }
        else {
            shift @$c;
        }
    }

    return $impl;
}

sub _override_info {
    my $info = shift;
    my $arg_map = shift;
    my $args = shift;
    foreach my $arg (keys %$arg_map) {
        next if not defined $args->{$arg};
        my $to = $arg_map->{$arg};
        if (ref($to)) {
            my $ary = $info->{shift(@$to)};
            $ary->[$_]{$to->[0]} = $args->{$arg} for 0..$#$ary;
        }
        else {
            $info->{$to} = $args->{$arg};
        }
    }
}

1;
__END__