diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/PAR/Dist.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/PAR/Dist.pm | 1425 |
1 files changed, 1425 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/PAR/Dist.pm b/Master/tlpkg/tlperl0/lib/PAR/Dist.pm new file mode 100755 index 00000000000..2c39a54804a --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/PAR/Dist.pm @@ -0,0 +1,1425 @@ +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; + +=head1 NAME + +PAR::Dist - Create and manipulate PAR distributions + +=head1 VERSION + +This document describes version 0.47 of PAR::Dist, released November 29, 2009. + +=head1 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 + +=head1 DESCRIPTION + +This module creates and manipulates I<PAR distributions>. They are +architecture-specific B<PAR> files, containing everything under F<blib/> +of CPAN distributions after their C<make> or C<Build> stage, a +F<META.yml> describing metadata of the original CPAN distribution, +and a F<MANIFEST> detailing all files within it. Digitally signed PAR +distributions will also contain a F<SIGNATURE> file. + +The naming convention for such distributions is: + + $NAME-$VERSION-$ARCH-$PERL_VERSION.par + +For example, C<PAR-Dist-0.01-i386-freebsd-5.8.0.par> corresponds to the +0.01 release of C<PAR-Dist> on CPAN, built for perl 5.8.0 running on +C<i386-freebsd>. + +=head1 FUNCTIONS + +Several functions are exported by default. Unless otherwise noted, +they can take either a hash of +named arguments, a single argument (taken as C<$path> by C<blib_to_par> +and C<$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 F<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 C<$dist> resembles a URL, C<LWP::Simple::mirror> is called to mirror it +locally under C<$ENV{PAR_TEMP}> (or C<$TEMP/par/> if unspecified), and the +function will act on the fetched local file instead. If the URL begins +with C<cpan://AUTHOR/>, it will be expanded automatically to the author's CPAN +directory (e.g. C<http://www.cpan.org/modules/by-authors/id/A/AU/AUTHOR/>). + +If C<$dist> does not have a file extension beginning with a letter or +underscore, a dash and C<$suffix> ($ARCH-$PERL_VERSION.par by default) +will be appended to it. + +=head2 blib_to_par + +Takes key/value pairs as parameters or a single parameter indicating the +path that contains the F<blib/> subdirectory. + +Builds a PAR distribution from the F<blib/> subdirectory under C<path>, or +under the current directory if unspecified. If F<blib/> does not exist, +it automatically runs F<Build>, F<make>, F<Build.PL> or F<Makefile.PL> to +create it. + +Returns the filename of the generated PAR distribution. + +Valid parameters are: + +=over 2 + +=item path + +Sets the path which contains the F<blib/> subdirectory from which the PAR +distribution will be generated. + +=item 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 F<META.yml> or F<Makefile.PL> files. + +The suffix is generated from your architecture name and your version of +perl by default. + +=item dist + +The output filename for the PAR distribution. + +=item quiet + +Set to true to suppress as much output as possible. + +=back + +=cut + +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}); + } +} + +=head2 install_par + +Installs a PAR distribution into the system, using +C<ExtUtils::Install::install_default>. + +If only a single parameter is given, it is treated as the value for the +C<dist> parameter. + +Valid named parameters are: + +=over 2 + +=item dist + +The .par file to install. The heuristics outlined in the B<FUNCTIONS> +section above apply. + +=item prefix + +This string will be prepended to all installation paths. +If it isn't specified, the environment variable +C<PERL_INSTALL_ROOT> is used as a prefix. + +=item uninstall_shadows + +This corresponds to the C<uninstall_shadows> option of L<ExtUtils::Install>. Quoting its manual: +If C<uninstall_shadows> is set to true, any differing versions throughout C<@INC> +will be uninstalled. This is C<make install UNINST=1>. + +=item verbose + +This corresponds to the C<verbose> option of L<ExtUtils::Install>. According to its manual: +If C<verbose> is true, will print out each file removed. This is C<make install VERBINST=1>. +C<verbose> values going up to 5 show increasingly more diagnostics output. + +Default verbosity for PAR::Dist is 1. + +=back + +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 C<packlist_write> parameter is used to control where the F<.packlist> +file is written to. (Necessary for uninstallation.) +The C<packlist_read> parameter specifies a .packlist file to merge in if +it exists. By setting any of the above installation targets to C<undef>, +you can remove that target altogether. For example, passing +C<< 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 I<site> paths from C<%Config>. + +(*) If the C<.par>'s I<inst_archlib> section (normally C<blib/arch>) +isn't empty, the code in I<inst_lib> (normally C<blib/lib>) is also installed +into the I<inst_archlib> path. This makes sense for XS modules. +If, however, you override C<inst_lib>, this automatic conversion is +also overridden! You can use the named parameter +C<auto_inst_lib_conversion =E<gt> 1> to re-enable the conversion +for custom I<inst_lib>'s. + +Finally, you may specify a C<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 F<.par> archives contents to arbitrary +locations. + +=cut + +sub install_par { + my %args = &_args; + _install_or_uninstall(%args, action => 'install'); +} + +=head2 uninstall_par + +Uninstalls all previously installed contents of a PAR distribution, +using C<ExtUtils::Install::uninstall>. + +Takes almost the same parameters as C<install_par>, but naturally, +the installation target parameters do not apply. The only exception +to this is the C<packlist_read> parameter which specifies the +F<.packlist> file to read the list of installed files from. +It defaults to C<$Config::Config{installsitearch}/auto/$name/.packlist>. + +Additionally, the C<uninstall_shadows> parameter of C<install_par> +isn't available. + +=cut + +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; +} + +=head2 sign_par + +Digitally sign a PAR distribution using C<gpg> or B<Crypt::OpenPGP>, +via B<Module::Signature>. + +=cut + +sub sign_par { + my %args = &_args; + _verify_or_sign(%args, action => 'sign'); +} + +=head2 verify_par + +Verify the digital signature of a PAR distribution using C<gpg> or +B<Crypt::OpenPGP>, via B<Module::Signature>. + +Returns a boolean value indicating whether verification passed; C<$!> +is set to the return code of C<Module::Signature::verify>. + +=cut + +sub verify_par { + my %args = &_args; + $! = _verify_or_sign(%args, action => 'verify'); + return ( $! == Module::Signature::SIGNATURE_OK() ); +} + +=head2 merge_par + +I<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 C<foo.par>, C<bar.par> and C<baz.par> +into the distribution C<foo.par>. C<foo.par> will be overwritten! + +The original META.yml of C<foo.par> is retained, but augmented with any +C<provides>, C<requires>, C<recommends>, C<build_requires>, and +C<configure_requires> sections from the other C<.par> files. + +=cut + +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 + } + } +} + +=head2 remove_man + +Remove the man pages from a PAR distribution. Takes one named +parameter: I<dist> which should be the name (and path) of the +PAR distribution file. The calling conventions outlined in +the C<FUNCTIONS> section above apply. + +The PAR archive will be +extracted, stripped of all C<man\d?> and C<html> subdirectories +and then repackaged into the original file. + +=cut + +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]); +} + + +=head2 get_meta + +Opens a PAR archive and extracts the contained META.yml file. +Returns the META.yml file as a string. + +Takes one named parameter: I<dist>. If only one parameter is +passed, it is treated as the I<dist> parameter. (Have a look +at the description in the C<FUNCTIONS> section above.) + +Returns undef if no PAR archive or no META.yml within the +archive were found. + +=cut + +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); +} + + + +=head2 parse_dist_name + +First argument must be a distribution file name. The file name +is parsed into I<distribution name>, I<distribution version>, +I<architecture name>, and I<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 C<PAR::Dist> +0.22, versions containing a preceding C<v> are parsed correctly. + +This function is not exported by default. + +=cut + +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); +} + +=head2 generate_blib_stub + +Creates a F<blib/lib> subdirectory in the current directory +and prepares a F<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 C<parse_dist_name()>. +Alternatively, named arguments resembling those of +C<blib_to_par> are accepted. + +After running C<generate_blib_stub> and injecting files into +the F<blib> directory, you can create a PAR distribution +using C<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! + +C<generate_blib_stub> will not overwrite existing files. + +=cut + +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; +} + + +=head2 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: I<dist>. If only one parameter is +passed, it is treated as the I<dist> parameter. (Have a look +at the description in the C<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. + +=cut + +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; + +=head1 SEE ALSO + +L<PAR>, L<ExtUtils::Install>, L<Module::Signature>, L<LWP::Simple> + +=head1 AUTHORS + +Audrey Tang E<lt>cpan@audreyt.orgE<gt> 2003-2007 + +Steffen Mueller E<lt>smueller@cpan.orgE<gt> 2005-2009 + +PAR has a mailing list, E<lt>par@perl.orgE<gt>, that you can write to; +send an empty mail to E<lt>par-subscribe@perl.orgE<gt> to join the list +and participate in the discussion. + +Please send bug reports to E<lt>bug-par@rt.cpan.orgE<gt>. + +=head1 COPYRIGHT + +Copyright 2003-2009 by Audrey Tang E<lt>autrijus@autrijus.orgE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut |