556 lines
16 KiB
Perl
556 lines
16 KiB
Perl
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
|