PAR::Dist - Create and manipulate PAR distributions
Index
Code Index:
NAME
PAR::Dist - Create and manipulate PAR distributions
VERSION
This document describes version 0.47 of PAR::Dist, released November 29, 2009.
SYNOPSIS
As a shell command:
% perl -MPAR::Dist -eblib_to_par
In programs:
use PAR::Dist;
my $dist = blib_to_par(); # make a PAR file using ./blib/
install_par($dist); # install it into the system
uninstall_par($dist); # uninstall it from the system
sign_par($dist); # sign it using Module::Signature
verify_par($dist); # verify it using Module::Signature
install_par("http://foo.com/DBI-1.37-MSWin32-5.8.0.par"); # works too
install_par("http://foo.com/DBI-1.37"); # auto-appends archname + perlver
install_par("cpan://SMUELLER/PAR-Packer-0.975"); # uses CPAN author directory
DESCRIPTION
This module creates and manipulates PAR distributions. They are
architecture-specific PAR files, containing everything under blib/
of CPAN distributions after their make or Build stage, a
META.yml describing metadata of the original CPAN distribution,
and a MANIFEST detailing all files within it. Digitally signed PAR
distributions will also contain a SIGNATURE file.
The naming convention for such distributions is:
$NAME-$VERSION-$ARCH-$PERL_VERSION.par
For example, PAR-Dist-0.01-i386-freebsd-5.8.0.par corresponds to the
0.01 release of PAR-Dist on CPAN, built for perl 5.8.0 running on
i386-freebsd.
FUNCTIONS
Several functions are exported by default. Unless otherwise noted,
they can take either a hash of
named arguments, a single argument (taken as $path by blib_to_par
and $dist by other functions), or no arguments (in which case
the first PAR file in the current directory is used).
Therefore, under a directory containing only a single test.par, all
invocations below are equivalent:
% perl -MPAR::Dist -e"install_par( dist => 'test.par' )"
% perl -MPAR::Dist -e"install_par( 'test.par' )"
% perl -MPAR::Dist -einstall_par;
If $dist resembles a URL, LWP::Simple::mirror is called to mirror it
locally under $ENV{PAR_TEMP} (or $TEMP/par/ if unspecified), and the
function will act on the fetched local file instead. If the URL begins
with cpan://AUTHOR/, it will be expanded automatically to the author's CPAN
directory (e.g. http://www.cpan.org/modules/by-authors/id/A/AU/AUTHOR/).
If $dist does not have a file extension beginning with a letter or
underscore, a dash and $suffix ($ARCH-$PERL_VERSION.par by default)
will be appended to it.
blib_to_par
Takes key/value pairs as parameters or a single parameter indicating the
path that contains the blib/ subdirectory.
Builds a PAR distribution from the blib/ subdirectory under path, or
under the current directory if unspecified. If blib/ does not exist,
it automatically runs Build, make, Build.PL or Makefile.PL to
create it.
Returns the filename of the generated PAR distribution.
Valid parameters are:
- path
-
Sets the path which contains the blib/ subdirectory from which the PAR
distribution will be generated.
- name, version, suffix
-
These attributes set the name, version and platform specific suffix
of the distribution. Name and version can be automatically
determined from the distributions META.yml or Makefile.PL files.
The suffix is generated from your architecture name and your version of
perl by default.
- dist
-
The output filename for the PAR distribution.
- quiet
-
Set to true to suppress as much output as possible.
install_par
Installs a PAR distribution into the system, using
ExtUtils::Install::install_default.
If only a single parameter is given, it is treated as the value for the
dist parameter.
Valid named parameters are:
- dist
-
The .par file to install. The heuristics outlined in the FUNCTIONS
section above apply.
- prefix
-
This string will be prepended to all installation paths.
If it isn't specified, the environment variable
PERL_INSTALL_ROOT is used as a prefix.
- uninstall_shadows
-
This corresponds to the uninstall_shadows option of ExtUtils::Install. Quoting its manual:
If uninstall_shadows is set to true, any differing versions throughout @INC
will be uninstalled. This is make install UNINST=1.
- verbose
-
This corresponds to the verbose option of ExtUtils::Install. According to its manual:
If verbose is true, will print out each file removed. This is make install VERBINST=1.
verbose values going up to 5 show increasingly more diagnostics output.
Default verbosity for PAR::Dist is 1.
If you're just going to install into the running perl like everything else,
you can stop reading the rest of this section now.
Additionally, you can use several parameters to change the default
installation destinations. You don't usually have to worry about this
unless you are installing into a user-local directory.
The following section outlines the parameter names and default settings:
Parameter From To
inst_lib blib/lib $Config{installsitelib} (*)
inst_archlib blib/arch $Config{installsitearch}
inst_script blib/script $Config{installscript}
inst_bin blib/bin $Config{installbin}
inst_man1dir blib/man1 $Config{installman1dir}
inst_man3dir blib/man3 $Config{installman3dir}
packlist_read $Config{sitearchexp}/auto/$name/.packlist
packlist_write $Config{installsitearch}/auto/$name/.packlist
The packlist_write parameter is used to control where the .packlist
file is written to. (Necessary for uninstallation.)
The packlist_read parameter specifies a .packlist file to merge in if
it exists. By setting any of the above installation targets to undef,
you can remove that target altogether. For example, passing
inst_man1dir => undef, inst_man3dir => undef means that the contained
manual pages won't be installed. This is not available for the packlists.
Again, the defaults will be the normal site paths from %Config.
(*) If the .par's inst_archlib section (normally blib/arch)
isn't empty, the code in inst_lib (normally blib/lib) is also installed
into the inst_archlib path. This makes sense for XS modules.
If, however, you override inst_lib, this automatic conversion is
also overridden! You can use the named parameter
auto_inst_lib_conversion => 1 to re-enable the conversion
for custom inst_lib's.
Finally, you may specify a custom_targets parameter. Its value should be
a reference to a hash of custom installation targets such as
custom_targets => { 'blib/my_data' => '/some/path/my_data' }
You can use this to install the .par archives contents to arbitrary
locations.
uninstall_par
Uninstalls all previously installed contents of a PAR distribution,
using ExtUtils::Install::uninstall.
Takes almost the same parameters as install_par, but naturally,
the installation target parameters do not apply. The only exception
to this is the packlist_read parameter which specifies the
.packlist file to read the list of installed files from.
It defaults to $Config::Config{installsitearch}/auto/$name/.packlist.
Additionally, the uninstall_shadows parameter of install_par
isn't available.
sign_par
Digitally sign a PAR distribution using gpg or Crypt::OpenPGP,
via Module::Signature.
verify_par
Verify the digital signature of a PAR distribution using gpg or
Crypt::OpenPGP, via Module::Signature.
Returns a boolean value indicating whether verification passed; $!
is set to the return code of Module::Signature::verify.
merge_par
Note: Since version 0.32 of PAR::Dist, this function requires a YAML
reader. The order of precedence is:
YAML YAML::Syck YAML::Tiny YAML::XS
Merges two or more PAR distributions into one. First argument must
be the name of the distribution you want to merge all others into.
Any following arguments will be interpreted as the file names of
further PAR distributions to merge into the first one.
merge_par('foo.par', 'bar.par', 'baz.par')
This will merge the distributions foo.par, bar.par and baz.par
into the distribution foo.par. foo.par will be overwritten!
The original META.yml of foo.par is retained, but augmented with any
provides, requires, recommends, build_requires, and
configure_requires sections from the other .par files.
remove_man
Remove the man pages from a PAR distribution. Takes one named
parameter: dist which should be the name (and path) of the
PAR distribution file. The calling conventions outlined in
the FUNCTIONS section above apply.
The PAR archive will be
extracted, stripped of all man\d? and html subdirectories
and then repackaged into the original file.
Opens a PAR archive and extracts the contained META.yml file.
Returns the META.yml file as a string.
Takes one named parameter: dist. If only one parameter is
passed, it is treated as the dist parameter. (Have a look
at the description in the FUNCTIONS section above.)
Returns undef if no PAR archive or no META.yml within the
archive were found.
parse_dist_name
First argument must be a distribution file name. The file name
is parsed into distribution name, distribution version,
architecture name, and perl version.
Returns the results as a list in the above order.
If any or all of the above cannot be determined, returns undef instead
of the undetermined elements.
Supported formats are:
Math-Symbolic-0.502-x86_64-linux-gnu-thread-multi-5.8.7
Math-Symbolic-0.502
The ".tar.gz" or ".par" extensions as well as any
preceding paths are stripped before parsing. Starting with PAR::Dist
0.22, versions containing a preceding v are parsed correctly.
This function is not exported by default.
generate_blib_stub
Creates a blib/lib subdirectory in the current directory
and prepares a META.yml with meta information for a
new PAR distribution. First argument should be the name of the
PAR distribution in a format understood by parse_dist_name().
Alternatively, named arguments resembling those of
blib_to_par are accepted.
After running generate_blib_stub and injecting files into
the blib directory, you can create a PAR distribution
using blib_to_par.
This function is useful for creating custom PAR distributions
from scratch. (I.e. not from an unpacked CPAN distribution)
Example:
use PAR::Dist;
use File::Copy 'copy';
generate_blib_stub(
name => 'MyApp', version => '1.00'
);
copy('MyApp.pm', 'blib/lib/MyApp.pm');
blib_to_par(); # generates the .par file!
generate_blib_stub will not overwrite existing files.
contains_binaries
This function is not exported by default.
Opens a PAR archive tries to determine whether that archive
contains platform-specific binary code.
Takes one named parameter: dist. If only one parameter is
passed, it is treated as the dist parameter. (Have a look
at the description in the FUNCTIONS section above.)
Throws a fatal error if the PAR archive could not be found.
Returns one if the PAR was found to contain binary code
and zero otherwise.
SEE ALSO
AUTHORS
Audrey Tang <cpan@audreyt.org> 2003-2007
Steffen Mueller <smueller@cpan.org> 2005-2009
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@rt.cpan.org>.
COPYRIGHT
Copyright 2003-2009 by Audrey Tang <autrijus@autrijus.org>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See http://www.perl.com/perl/misc/Artistic.html
package PAR::Dist;
use 5.006;
use strict;
require Exporter;
use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK $DEBUG/;
$VERSION = '0.47'; # Change version in POD, too!
@ISA = 'Exporter';
@EXPORT = qw/
blib_to_par
install_par
uninstall_par
sign_par
verify_par
merge_par
remove_man
get_meta
generate_blib_stub
/;
@EXPORT_OK = qw/
parse_dist_name
contains_binaries
/;
$DEBUG = 0;
use Carp qw/carp croak/;
use File::Spec;
sub blib_to_par {
@_ = (path => @_) if @_ == 1;
my %args = @_;
require Config;
# don't use 'my $foo ... if ...' it creates a static variable!
my $quiet = $args{quiet} || 0;
my $dist;
my $path = $args{path};
$dist = File::Spec->rel2abs($args{dist}) if $args{dist};
my $name = $args{name};
my $version = $args{version};
my $suffix = $args{suffix} || "$Config::Config{archname}-$Config::Config{version}.par";
my $cwd;
if (defined $path) {
require Cwd;
$cwd = Cwd::cwd();
chdir $path;
}
_build_blib() unless -d "blib";
my @files;
open MANIFEST, ">", File::Spec->catfile("blib", "MANIFEST") or die $!;
open META, ">", File::Spec->catfile("blib", "META.yml") or die $!;
require File::Find;
File::Find::find( sub {
next unless $File::Find::name;
(-r && !-d) and push ( @files, substr($File::Find::name, 5) );
} , 'blib' );
print MANIFEST join(
"\n",
' <!-- accessible as jar:file:///NAME.par!/MANIFEST in compliant browsers -->',
(sort @files),
q( # <html><body onload="var X=document.body.innerHTML.split(/\n/);var Y='<iframe src="META.yml" style="float:right;height:40%;width:40%"></iframe><ul>';for(var x in X){if(!X[x].match(/^\s*#/)&&X[x].length)Y+='<li><a href="'+X[x]+'">'+X[x]+'</a>'}document.body.innerHTML=Y">)
);
close MANIFEST;
if (open(OLD_META, "META.yml")) {
while (<OLD_META>) {
if (/^distribution_type:/) {
print META "distribution_type: par\n";
}
else {
print META $_;
}
if (/^name:\s+(.*)/) {
$name ||= $1;
$name =~ s/::/-/g;
}
elsif (/^version:\s+.*Module::Build::Version/) {
while (<OLD_META>) {
/^\s+original:\s+(.*)/ or next;
$version ||= $1;
last;
}
}
elsif (/^version:\s+(.*)/) {
$version ||= $1;
}
}
close OLD_META;
close META;
}
if ((!$name or !$version) and open(MAKEFILE, "Makefile")) {
while (<MAKEFILE>) {
if (/^DISTNAME\s+=\s+(.*)$/) {
$name ||= $1;
}
elsif (/^VERSION\s+=\s+(.*)$/) {
$version ||= $1;
}
}
}
if (not defined($name) or not defined($version)) {
# could not determine name or version. Error.
my $what;
if (not defined $name) {
$what = 'name';
$what .= ' and version' if not defined $version;
}
elsif (not defined $version) {
$what = 'version';
}
carp("I was unable to determine the $what of the PAR distribution. Please create a Makefile or META.yml file from which we can infer the information or just specify the missing information as an option to blib_to_par.");
return();
}
$name =~ s/\s+$//;
$version =~ s/\s+$//;
my $file = "$name-$version-$suffix";
unlink $file if -f $file;
print META << "YAML" if fileno(META);
name: $name
version: $version
build_requires: {}
conflicts: {}
dist_name: $file
distribution_type: par
dynamic_config: 0
generated_by: 'PAR::Dist version $PAR::Dist::VERSION'
license: unknown
YAML
close META;
mkdir('blib', 0777);
chdir('blib');
require Cwd;
my $zipoutfile = File::Spec->catfile(File::Spec->updir, $file);
_zip(dist => $zipoutfile);
chdir(File::Spec->updir);
unlink File::Spec->catfile("blib", "MANIFEST");
unlink File::Spec->catfile("blib", "META.yml");
$dist ||= File::Spec->catfile($cwd, $file) if $cwd;
if ($dist and $file ne $dist) {
if ( File::Copy::copy($file, $dist) ) {
unlink $file;
} else {
die "Cannot copy $file: $!";
}
$file = $dist;
}
my $pathname = File::Spec->rel2abs($file);
if ($^O eq 'MSWin32') {
$pathname =~ s!\\!/!g;
$pathname =~ s!:!|!g;
};
print << "." if !$quiet;
Successfully created binary distribution '$file'.
Its contents are accessible in compliant browsers as:
jar:file://$pathname!/MANIFEST
.
chdir $cwd if $cwd;
return $file;
}
sub _build_blib {
if (-e 'Build') {
_system_wrapper($^X, "Build");
}
elsif (-e 'Makefile') {
_system_wrapper($Config::Config{make});
}
elsif (-e 'Build.PL') {
_system_wrapper($^X, "Build.PL");
_system_wrapper($^X, "Build");
}
elsif (-e 'Makefile.PL') {
_system_wrapper($^X, "Makefile.PL");
_system_wrapper($Config::Config{make});
}
}
sub install_par {
my %args = &_args;
_install_or_uninstall(%args, action => 'install');
}
sub uninstall_par {
my %args = &_args;
_install_or_uninstall(%args, action => 'uninstall');
}
sub _install_or_uninstall {
my %args = &_args;
my $name = $args{name};
my $action = $args{action};
my %ENV_copy = %ENV;
$ENV{PERL_INSTALL_ROOT} = $args{prefix} if defined $args{prefix};
require Cwd;
my $old_dir = Cwd::cwd();
my ($dist, $tmpdir) = _unzip_to_tmpdir( dist => $args{dist}, subdir => 'blib' );
if ( open (META, File::Spec->catfile('blib', 'META.yml')) ) {
while (<META>) {
next unless /^name:\s+(.*)/;
$name = $1;
$name =~ s/\s+$//;
last;
}
close META;
}
return if not defined $name or $name eq '';
if (-d 'script') {
require ExtUtils::MY;
foreach my $file (glob("script/*")) {
next unless -T $file;
ExtUtils::MY->fixin($file);
chmod(0555, $file);
}
}
$name =~ s{::|-}{/}g;
require ExtUtils::Install;
if ($action eq 'install') {
my $target = _installation_target( File::Spec->curdir, $name, \%args );
my $custom_targets = $args{custom_targets} || {};
$target->{$_} = $custom_targets->{$_} foreach keys %{$custom_targets};
my $uninstall_shadows = $args{uninstall_shadows};
my $verbose = $args{verbose};
ExtUtils::Install::install($target, $verbose, 0, $uninstall_shadows);
}
elsif ($action eq 'uninstall') {
require Config;
my $verbose = $args{verbose};
ExtUtils::Install::uninstall(
$args{packlist_read}||"$Config::Config{installsitearch}/auto/$name/.packlist",
$verbose
);
}
%ENV = %ENV_copy;
chdir($old_dir);
File::Path::rmtree([$tmpdir]);
return 1;
}
# Returns the default installation target as used by
# ExtUtils::Install::install(). First parameter should be the base
# directory containing the blib/ we're installing from.
# Second parameter should be the name of the distribution for the packlist
# paths. Third parameter may be a hash reference with user defined keys for
# the target hash. In fact, any contents that do not start with 'inst_' are
# skipped.
sub _installation_target {
require Config;
my $dir = shift;
my $name = shift;
my $user = shift || {};
# accepted sources (and user overrides)
my %sources = (
inst_lib => File::Spec->catdir($dir,"blib","lib"),
inst_archlib => File::Spec->catdir($dir,"blib","arch"),
inst_bin => File::Spec->catdir($dir,'blib','bin'),
inst_script => File::Spec->catdir($dir,'blib','script'),
inst_man1dir => File::Spec->catdir($dir,'blib','man1'),
inst_man3dir => File::Spec->catdir($dir,'blib','man3'),
packlist_read => 'read',
packlist_write => 'write',
);
my $par_has_archlib = _directory_not_empty( $sources{inst_archlib} );
# default targets
my $target = {
read => $Config::Config{sitearchexp}."/auto/$name/.packlist",
write => $Config::Config{installsitearch}."/auto/$name/.packlist",
$sources{inst_lib} =>
($par_has_archlib
? $Config::Config{installsitearch}
: $Config::Config{installsitelib}),
$sources{inst_archlib} => $Config::Config{installsitearch},
$sources{inst_bin} => $Config::Config{installbin} ,
$sources{inst_script} => $Config::Config{installscript},
$sources{inst_man1dir} => $Config::Config{installman1dir},
$sources{inst_man3dir} => $Config::Config{installman3dir},
};
# Included for future support for ${flavour}perl external lib installation
# if ($Config::Config{flavour_perl}) {
# my $ext = File::Spec->catdir($dir, 'blib', 'ext');
# # from => to
# $sources{inst_external_lib} = File::Spec->catdir($ext, 'lib');
# $sources{inst_external_bin} = File::Spec->catdir($ext, 'bin');
# $sources{inst_external_include} = File::Spec->catdir($ext, 'include');
# $sources{inst_external_src} = File::Spec->catdir($ext, 'src');
# $target->{ $sources{inst_external_lib} } = $Config::Config{flavour_install_lib};
# $target->{ $sources{inst_external_bin} } = $Config::Config{flavour_install_bin};
# $target->{ $sources{inst_external_include} } = $Config::Config{flavour_install_include};
# $target->{ $sources{inst_external_src} } = $Config::Config{flavour_install_src};
# }
# insert user overrides
foreach my $key (keys %$user) {
my $value = $user->{$key};
if (not defined $value and $key ne 'packlist_read' and $key ne 'packlist_write') {
# undef means "remove"
delete $target->{ $sources{$key} };
}
elsif (exists $sources{$key}) {
# overwrite stuff, don't let the user create new entries
$target->{ $sources{$key} } = $value;
}
}
# apply the automatic inst_lib => inst_archlib conversion again
# if the user asks for it and there is an archlib in the .par
if ($user->{auto_inst_lib_conversion} and $par_has_archlib) {
$target->{inst_lib} = $target->{inst_archlib};
}
return $target;
}
sub _directory_not_empty {
require File::Find;
my($dir) = @_;
my $files = 0;
File::Find::find(sub {
return if $_ eq ".exists";
if (-f) {
$File::Find::prune++;
$files = 1;
}
}, $dir);
return $files;
}
sub sign_par {
my %args = &_args;
_verify_or_sign(%args, action => 'sign');
}
sub verify_par {
my %args = &_args;
$! = _verify_or_sign(%args, action => 'verify');
return ( $! == Module::Signature::SIGNATURE_OK() );
}
sub merge_par {
my $base_par = shift;
my @additional_pars = @_;
require Cwd;
require File::Copy;
require File::Path;
require File::Find;
# parameter checking
if (not defined $base_par) {
croak "First argument to merge_par() must be the .par archive to modify.";
}
if (not -f $base_par or not -r _ or not -w _) {
croak "'$base_par' is not a file or you do not have enough permissions to read and modify it.";
}
foreach (@additional_pars) {
if (not -f $_ or not -r _) {
croak "'$_' is not a file or you do not have enough permissions to read it.";
}
}
# The unzipping will change directories. Remember old dir.
my $old_cwd = Cwd::cwd();
# Unzip the base par to a temp. dir.
(undef, my $base_dir) = _unzip_to_tmpdir(
dist => $base_par, subdir => 'blib'
);
my $blibdir = File::Spec->catdir($base_dir, 'blib');
# move the META.yml to the (main) temp. dir.
my $main_meta_file = File::Spec->catfile($base_dir, 'META.yml');
File::Copy::move(
File::Spec->catfile($blibdir, 'META.yml'),
$main_meta_file
);
# delete (incorrect) MANIFEST
unlink File::Spec->catfile($blibdir, 'MANIFEST');
# extract additional pars and merge
foreach my $par (@additional_pars) {
# restore original directory because the par path
# might have been relative!
chdir($old_cwd);
(undef, my $add_dir) = _unzip_to_tmpdir(
dist => $par
);
# merge the meta (at least the provides info) into the main meta.yml
my $meta_file = File::Spec->catfile($add_dir, 'META.yml');
if (-f $meta_file) {
_merge_meta($main_meta_file, $meta_file);
}
my @files;
my @dirs;
# I hate File::Find
# And I hate writing portable code, too.
File::Find::find(
{wanted =>sub {
my $file = $File::Find::name;
push @files, $file if -f $file;
push @dirs, $file if -d _;
}},
$add_dir
);
my ($vol, $subdir, undef) = File::Spec->splitpath( $add_dir, 1);
my @dir = File::Spec->splitdir( $subdir );
# merge directory structure
foreach my $dir (@dirs) {
my ($v, $d, undef) = File::Spec->splitpath( $dir, 1 );
my @d = File::Spec->splitdir( $d );
shift @d foreach @dir; # remove tmp dir from path
my $target = File::Spec->catdir( $blibdir, @d );
mkdir($target);
}
# merge files
foreach my $file (@files) {
my ($v, $d, $f) = File::Spec->splitpath( $file );
my @d = File::Spec->splitdir( $d );
shift @d foreach @dir; # remove tmp dir from path
my $target = File::Spec->catfile(
File::Spec->catdir( $blibdir, @d ),
$f
);
File::Copy::copy($file, $target)
or die "Could not copy '$file' to '$target': $!";
}
chdir($old_cwd);
File::Path::rmtree([$add_dir]);
}
# delete (copied) MANIFEST and META.yml
unlink File::Spec->catfile($blibdir, 'MANIFEST');
unlink File::Spec->catfile($blibdir, 'META.yml');
chdir($base_dir);
my $resulting_par_file = Cwd::abs_path(blib_to_par(quiet => 1));
chdir($old_cwd);
File::Copy::move($resulting_par_file, $base_par);
File::Path::rmtree([$base_dir]);
}
sub _merge_meta {
my $meta_orig_file = shift;
my $meta_extra_file = shift;
return() if not defined $meta_orig_file or not -f $meta_orig_file;
return 1 if not defined $meta_extra_file or not -f $meta_extra_file;
my $yaml_functions = _get_yaml_functions();
die "Cannot merge META.yml files without a YAML reader/writer"
if !exists $yaml_functions->{LoadFile}
or !exists $yaml_functions->{DumpFile};
my $orig_meta = $yaml_functions->{LoadFile}->($meta_orig_file);
my $extra_meta = $yaml_functions->{LoadFile}->($meta_extra_file);
# I seem to remember there was this incompatibility between the different
# YAML implementations with regards to "document" handling:
my $orig_tree = (ref($orig_meta) eq 'ARRAY' ? $orig_meta->[0] : $orig_meta);
my $extra_tree = (ref($extra_meta) eq 'ARRAY' ? $extra_meta->[0] : $extra_meta);
_merge_provides($orig_tree, $extra_tree);
_merge_requires($orig_tree, $extra_tree);
$yaml_functions->{DumpFile}->($meta_orig_file, $orig_meta);
return 1;
}
# merge the two-level provides sections of META.yml
sub _merge_provides {
my $orig_hash = shift;
my $extra_hash = shift;
return() if not exists $extra_hash->{provides};
$orig_hash->{provides} ||= {};
my $orig_provides = $orig_hash->{provides};
my $extra_provides = $extra_hash->{provides};
# two level clone is enough wrt META spec 1.4
# overwrite the original provides since we're also overwriting the files.
foreach my $module (keys %$extra_provides) {
my $extra_mod_hash = $extra_provides->{$module};
my %mod_hash;
$mod_hash{$_} = $extra_mod_hash->{$_} for keys %$extra_mod_hash;
$orig_provides->{$module} = \%mod_hash;
}
}
# merge the single-level requires-like sections of META.yml
sub _merge_requires {
my $orig_hash = shift;
my $extra_hash = shift;
foreach my $type (qw(requires build_requires configure_requires recommends)) {
next if not exists $extra_hash->{$type};
$orig_hash->{$type} ||= {};
# one level clone is enough wrt META spec 1.4
foreach my $module (keys %{ $extra_hash->{$type} }) {
# FIXME there should be a version comparison here, BUT how are we going to do that without a guaranteed version.pm?
$orig_hash->{$type}{$module} = $extra_hash->{$type}{$module}; # assign version and module name
}
}
}
sub remove_man {
my %args = &_args;
my $par = $args{dist};
require Cwd;
require File::Copy;
require File::Path;
require File::Find;
# parameter checking
if (not defined $par) {
croak "First argument to remove_man() must be the .par archive to modify.";
}
if (not -f $par or not -r _ or not -w _) {
croak "'$par' is not a file or you do not have enough permissions to read and modify it.";
}
# The unzipping will change directories. Remember old dir.
my $old_cwd = Cwd::cwd();
# Unzip the base par to a temp. dir.
(undef, my $base_dir) = _unzip_to_tmpdir(
dist => $par, subdir => 'blib'
);
my $blibdir = File::Spec->catdir($base_dir, 'blib');
# move the META.yml to the (main) temp. dir.
File::Copy::move(
File::Spec->catfile($blibdir, 'META.yml'),
File::Spec->catfile($base_dir, 'META.yml')
);
# delete (incorrect) MANIFEST
unlink File::Spec->catfile($blibdir, 'MANIFEST');
opendir DIRECTORY, 'blib' or die $!;
my @dirs = grep { /^blib\/(?:man\d*|html)$/ }
grep { -d $_ }
map { File::Spec->catfile('blib', $_) }
readdir DIRECTORY;
close DIRECTORY;
File::Path::rmtree(\@dirs);
chdir($base_dir);
my $resulting_par_file = Cwd::abs_path(blib_to_par());
chdir($old_cwd);
File::Copy::move($resulting_par_file, $par);
File::Path::rmtree([$base_dir]);
}
sub get_meta {
my %args = &_args;
my $dist = $args{dist};
return undef if not defined $dist or not -r $dist;
require Cwd;
require File::Path;
# The unzipping will change directories. Remember old dir.
my $old_cwd = Cwd::cwd();
# Unzip the base par to a temp. dir.
(undef, my $base_dir) = _unzip_to_tmpdir(
dist => $dist, subdir => 'blib'
);
my $blibdir = File::Spec->catdir($base_dir, 'blib');
my $meta = File::Spec->catfile($blibdir, 'META.yml');
if (not -r $meta) {
return undef;
}
open FH, '<', $meta
or die "Could not open file '$meta' for reading: $!";
local $/ = undef;
my $meta_text = <FH>;
close FH;
chdir($old_cwd);
File::Path::rmtree([$base_dir]);
return $meta_text;
}
sub _unzip {
my %args = &_args;
my $dist = $args{dist};
my $path = $args{path} || File::Spec->curdir;
return unless -f $dist;
# Try fast unzipping first
if (eval { require Archive::Unzip::Burst; 1 }) {
my $return = !Archive::Unzip::Burst::unzip($dist, $path);
return if $return; # true return value == error (a la system call)
}
# Then slow unzipping
if (eval { require Archive::Zip; 1 }) {
my $zip = Archive::Zip->new;
local %SIG;
$SIG{__WARN__} = sub { print STDERR $_[0] unless $_[0] =~ /\bstat\b/ };
return unless $zip->read($dist) == Archive::Zip::AZ_OK()
and $zip->extractTree('', "$path/") == Archive::Zip::AZ_OK();
}
# Then fall back to the system
else {
undef $!;
if (_system_wrapper(unzip => $dist, '-d', $path)) {
die "Failed to unzip '$dist' to path '$path': Could neither load "
. "Archive::Zip nor (successfully) run the system 'unzip' (unzip said: $!)";
}
}
return 1;
}
sub _zip {
my %args = &_args;
my $dist = $args{dist};
if (eval { require Archive::Zip; 1 }) {
my $zip = Archive::Zip->new;
$zip->addTree( File::Spec->curdir, '' );
$zip->writeToFileNamed( $dist ) == Archive::Zip::AZ_OK() or die $!;
}
else {
undef $!;
if (_system_wrapper(qw(zip -r), $dist, File::Spec->curdir)) {
die "Failed to zip '" .File::Spec->curdir(). "' to '$dist': Could neither load "
. "Archive::Zip nor (successfully) run the system 'zip' (zip said: $!)";
}
}
return 1;
}
# This sub munges the arguments to most of the PAR::Dist functions
# into a hash. On the way, it downloads PAR archives as necessary, etc.
sub _args {
# default to the first .par in the CWD
if (not @_) {
@_ = (glob('*.par'))[0];
}
# single argument => it's a distribution file name or URL
@_ = (dist => @_) if @_ == 1;
my %args = @_;
$args{name} ||= $args{dist};
# If we are installing from an URL, we want to munge the
# distribution name so that it is in form "Module-Name"
if (defined $args{name}) {
$args{name} =~ s/^\w+:\/\///;
my @elems = parse_dist_name($args{name});
# @elems is name, version, arch, perlversion
if (defined $elems[0]) {
$args{name} = $elems[0];
}
else {
$args{name} =~ s/^.*\/([^\/]+)$/$1/;
$args{name} =~ s/^([0-9A-Za-z_-]+)-\d+\..+$/$1/;
}
}
# append suffix if there is none
if ($args{dist} and not $args{dist} =~ /\.[a-zA-Z_][^.]*$/) {
require Config;
my $suffix = $args{suffix};
$suffix ||= "$Config::Config{archname}-$Config::Config{version}.par";
$args{dist} .= "-$suffix";
}
# download if it's an URL
if ($args{dist} and $args{dist} =~ m!^\w+://!) {
$args{dist} = _fetch(dist => $args{dist})
}
return %args;
}
# Download PAR archive, but only if necessary (mirror!)
my %escapes;
sub _fetch {
my %args = @_;
if ($args{dist} =~ s/^file:\/\///) {
return $args{dist} if -e $args{dist};
return;
}
require LWP::Simple;
$ENV{PAR_TEMP} ||= File::Spec->catdir(File::Spec->tmpdir, 'par');
mkdir $ENV{PAR_TEMP}, 0777;
%escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255 unless %escapes;
$args{dist} =~ s{^cpan://((([a-zA-Z])[a-zA-Z])[-_a-zA-Z]+)/}
{http://www.cpan.org/modules/by-authors/id/\U$3/$2/$1\E/};
my $file = $args{dist};
$file =~ s/([^\w\.])/$escapes{$1}/g;
$file = File::Spec->catfile( $ENV{PAR_TEMP}, $file);
my $rc = LWP::Simple::mirror( $args{dist}, $file );
if (!LWP::Simple::is_success($rc) and $rc != 304) {
die "Error $rc: ", LWP::Simple::status_message($rc), " ($args{dist})\n";
}
return $file if -e $file;
return;
}
sub _verify_or_sign {
my %args = &_args;
require File::Path;
require Module::Signature;
die "Module::Signature version 0.25 required"
unless Module::Signature->VERSION >= 0.25;
require Cwd;
my $cwd = Cwd::cwd();
my $action = $args{action};
my ($dist, $tmpdir) = _unzip_to_tmpdir($args{dist});
$action ||= (-e 'SIGNATURE' ? 'verify' : 'sign');
if ($action eq 'sign') {
open FH, '>SIGNATURE' unless -e 'SIGNATURE';
open FH, 'MANIFEST' or die $!;
local $/;
my $out = <FH>;
if ($out !~ /^SIGNATURE(?:\s|$)/m) {
$out =~ s/^(?!\s)/SIGNATURE\n/m;
open FH, '>MANIFEST' or die $!;
print FH $out;
}
close FH;
$args{overwrite} = 1 unless exists $args{overwrite};
$args{skip} = 0 unless exists $args{skip};
}
my $rv = Module::Signature->can($action)->(%args);
_zip(dist => $dist) if $action eq 'sign';
File::Path::rmtree([$tmpdir]);
chdir($cwd);
return $rv;
}
sub _unzip_to_tmpdir {
my %args = &_args;
require File::Temp;
my $dist = File::Spec->rel2abs($args{dist});
my $tmpdirname = File::Spec->catdir(File::Spec->tmpdir, "parXXXXX");
my $tmpdir = File::Temp::mkdtemp($tmpdirname)
or die "Could not create temporary directory from template '$tmpdirname': $!";
my $path = $tmpdir;
$path = File::Spec->catdir($tmpdir, $args{subdir}) if defined $args{subdir};
_unzip(dist => $dist, path => $path);
chdir $tmpdir;
return ($dist, $tmpdir);
}
sub parse_dist_name {
my $file = shift;
return(undef, undef, undef, undef) if not defined $file;
(undef, undef, $file) = File::Spec->splitpath($file);
my $version = qr/v?(?:\d+(?:_\d+)?|\d*(?:\.\d+(?:_\d+)?)+)/;
$file =~ s/\.(?:par|tar\.gz|tar)$//i;
my @elem = split /-/, $file;
my (@dn, $dv, @arch, $pv);
while (@elem) {
my $e = shift @elem;
if (
$e =~ /^$version$/o
and not(# if not next token also a version
# (assumes an arch string doesnt start with a version...)
@elem and $elem[0] =~ /^$version$/o
)
) {
$dv = $e;
last;
}
push @dn, $e;
}
my $dn;
$dn = join('-', @dn) if @dn;
if (not @elem) {
return( $dn, $dv, undef, undef);
}
while (@elem) {
my $e = shift @elem;
if ($e =~ /^$version|any_version$/) {
$pv = $e;
last;
}
push @arch, $e;
}
my $arch;
$arch = join('-', @arch) if @arch;
return($dn, $dv, $arch, $pv);
}
sub generate_blib_stub {
my %args = &_args;
my $dist = $args{dist};
require Config;
my $name = $args{name};
my $version = $args{version};
my $suffix = $args{suffix};
my ($parse_name, $parse_version, $archname, $perlversion)
= parse_dist_name($dist);
$name ||= $parse_name;
$version ||= $parse_version;
$suffix = "$archname-$perlversion"
if (not defined $suffix or $suffix eq '')
and $archname and $perlversion;
$suffix ||= "$Config::Config{archname}-$Config::Config{version}";
if ( grep { not defined $_ } ($name, $version, $suffix) ) {
warn "Could not determine distribution meta information from distribution name '$dist'";
return();
}
$suffix =~ s/\.par$//;
if (not -f 'META.yml') {
open META, '>', 'META.yml'
or die "Could not open META.yml file for writing: $!";
print META << "YAML" if fileno(META);
name: $name
version: $version
build_requires: {}
conflicts: {}
dist_name: $name-$version-$suffix.par
distribution_type: par
dynamic_config: 0
generated_by: 'PAR::Dist version $PAR::Dist::VERSION'
license: unknown
YAML
close META;
}
mkdir('blib');
mkdir(File::Spec->catdir('blib', 'lib'));
mkdir(File::Spec->catdir('blib', 'script'));
return 1;
}
sub contains_binaries {
require File::Find;
my %args = &_args;
my $dist = $args{dist};
return undef if not defined $dist or not -r $dist;
require Cwd;
require File::Path;
# The unzipping will change directories. Remember old dir.
my $old_cwd = Cwd::cwd();
# Unzip the base par to a temp. dir.
(undef, my $base_dir) = _unzip_to_tmpdir(
dist => $dist, subdir => 'blib'
);
my $blibdir = File::Spec->catdir($base_dir, 'blib');
my $archdir = File::Spec->catdir($blibdir, 'arch');
my $found = 0;
File::Find::find(
sub {
$found++ if -f $_ and not /^\.exists$/;
},
$archdir
);
chdir($old_cwd);
File::Path::rmtree([$base_dir]);
return $found ? 1 : 0;
}
sub _system_wrapper {
if ($DEBUG) {
Carp::cluck("Running system call '@_' from:");
}
return system(@_);
}
# stolen from Module::Install::Can
# very much internal and subject to change or removal
sub _MI_can_run {
require ExtUtils::MakeMaker;
my ($cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# Tries to load any YAML reader writer I know of
# returns nothing on failure or hash reference containing
# a subset of Load, Dump, LoadFile, DumpFile
# entries with sub references on success.
sub _get_yaml_functions {
# reasoning for the ranking here:
# - syck is fast and reasonably complete
# - YAML.pm is slow and aging
# - Tiny is only a very small subset
# - XS is very new and I'm not sure it's ready for prime-time yet
# - Parse... is only a reader and only deals with the same subset as ::Tiny
my @modules = qw(YAML::Syck YAML YAML::Tiny YAML::XS Parse::CPAN::Meta);
my %yaml_functions;
foreach my $module (@modules) {
eval "require $module;";
if (!$@) {
warn "PAR::Dist testers/debug info: Using '$module' as YAML implementation" if $DEBUG;
foreach my $sub (qw(Load Dump LoadFile DumpFile)) {
no strict 'refs';
my $subref = *{"${module}::$sub"}{CODE};
if (defined $subref and ref($subref) eq 'CODE') {
$yaml_functions{$sub} = $subref;
}
}
$yaml_functions{yaml_provider} = $module;
last;
}
} # end foreach module candidates
if (not keys %yaml_functions) {
warn "Cannot find a working YAML reader/writer implementation. Tried to load all of '@modules'";
}
return(\%yaml_functions);
}
sub _check_tools {
my $tools = _get_yaml_functions();
if ($DEBUG) {
foreach (qw/Load Dump LoadFile DumpFile/) {
warn "No YAML support for $_ found.\n" if not defined $tools->{$_};
}
}
$tools->{zip} = undef;
# A::Zip 1.28 was a broken release...
if (eval {require Archive::Zip; 1;} and $Archive::Zip::VERSION ne '1.28') {
warn "Using Archive::Zip as ZIP tool.\n" if $DEBUG;
$tools->{zip} = 'Archive::Zip';
}
elsif (_MI_can_run("zip") and _MI_can_run("unzip")) {
warn "Using zip/unzip as ZIP tool.\n" if $DEBUG;
$tools->{zip} = 'zip';
}
else {
warn "Found neither Archive::Zip (version != 1.28) nor ZIP/UNZIP as valid ZIP tools.\n" if $DEBUG;
$tools->{zip} = undef;
}
return $tools;
}
1;