path: root/Master/tlpkg/tlperl/lib/PAR/Dist/FromPPD.pm

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__

=head1 NAME

PAR::Dist::FromPPD - Create PAR distributions from PPD/PPM packages

=head1 SYNOPSIS

  use PAR::Dist::FromPPD;
  
  # Creates a .par distribution of the PAR module in the
  # current directory based on the PAR.ppd file from the excellent
  # bribes.org PPM repository.
  ppd_to_par(uri => 'http://www.bribes.org/perl/ppm/PAR.ppd');

  # You could download the .ppd and .tar.gz files first and then do:
  ppd_to_par(uri => 'PAR.ppd', verbose => 1);
  
=head1 DESCRIPTION

This module creates PAR distributions from PPD XML documents which
are used by ActiveState's "Perl Package Manager", short PPM.

It parses the PPD document to extract the required
information and then uses PAR::Dist to create a .par archive from it.

Please note that this code I<works for me> but hasn't been tested
to full extent.

=head2 EXPORT

By default, the C<ppd_to_par> subroutine is exported to the callers
namespace. C<get_ppd_content> will be exported on demand.

=head1 SUBROUTINES

This is a list of all public subroutines in the module.

=head2 ppd_to_par

The only mandatory parameter is an URI for the PPD file to parse.

Arguments:

  uri         => 'ftp://foo/bar' or 'file:///home/you/file.ppd', ...
  out         => 'directory'  (write distribution files to this directory)
  verbose     => 1/0 (verbose mode on/off)
  distname    => Override the distribution name
  distversion => Override the distribution version
  perlversion => Override the distribution's (minimum?) perl version
  arch        => Override the distribution's target architecture
  selectarch  => Regular Expression.
  selectperl  => Regular Expression.

C<arch> may also be set to C<any_arch> and C<perlversion> may be set to
C<any_version>.

If a regular expression is specified using C<selectarch>, that expression is
matched against the architecture settings of each implementation. The first
matching implementation is chosen. If none matches, the implementations
are tried in order of appearance. Of course, this heuristic is applied before
any architecture overriding via the C<arch> parameter is carried out.

C<selectperl> works the same as C<selectarch>, but operates on the (minimum)
perl version of an implementation. If both C<selectperl> and C<selectarch>
are present, C<selectperl> operates on the implementations matched by
C<selectarch>. That means C<selectarch> takes precedence.

=head2 get_ppd_content

First argument must be an URI string for the PPD.
(Supported are C<file://> URIs and whatever L<LWP>
supports.)

Fetches the PPD file and returns its contents as a string.

C<die()>s on error.

=head1 SEE ALSO

The L<PAR::Dist> module is used to create .par distributions from an
unpacked CPAN distribution. The L<CPAN> module is used to fetch the
distributions from the CPAN.

PAR has a mailing list, <par@perl.org>, that you can write to; send an empty mail to <par-subscribe@perl.org> to join the list and participate in the discussion.

Please send bug reports to <bug-par-dist-fromppd@rt.cpan.org>.

The official PAR website may be of help, too: http://par.perl.org

For details on the I<Perl Package Manager>, please refer to ActiveState's
website at L<http://activestate.com>.

=head1 AUTHOR

Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Steffen Mueller

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.6 or,
at your option, any later version of Perl 5 you may have available.

=cut