package PAR::Dist; require Exporter; use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK/; $VERSION = '0.29'; @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 /; use strict; use Carp qw/carp croak/; use File::Spec; sub blib_to_par { @_ = (path => @_) if @_ == 1; my %args = @_; require Config; 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", ' ', (sort @files), q( # ) ); close MANIFEST; if (open(OLD_META, "META.yml")) { while () { 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 () { /^\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 () { if (/^DISTNAME\s+=\s+(.*)$/) { $name ||= $1; } elsif (/^VERSION\s+=\s+(.*)$/) { $version ||= $1; } } } if (not defined($name) or not defined($version)) { 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'); _zip(dist => File::Spec->catfile(File::Spec->updir, $file)) or die $!; 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) { rename( $file => $dist ); $file = $dist; } my $pathname = File::Spec->rel2abs($file); if ($^O eq 'MSWin32') { $pathname =~ s!\\!/!g; $pathname =~ s!:!|!g; }; print << "."; 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($^X, "Build"); } elsif (-e 'Makefile') { system($Config::Config{make}); } elsif (-e 'Build.PL') { system($^X, "Build.PL"); system($^X, "Build"); } elsif (-e 'Makefile.PL') { system($^X, "Makefile.PL"); system($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 () { 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; my $rv; 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}; $rv = ExtUtils::Install::install($target, 1, 0, 0); } elsif ($action eq 'uninstall') { require Config; $rv = ExtUtils::Install::uninstall( $args{packlist_read}||"$Config::Config{installsitearch}/auto/$name/.packlist" ); } %ENV = %ENV_copy; chdir($old_dir); File::Path::rmtree([$tmpdir]); return $rv; } sub _installation_target { require Config; my $dir = shift; my $name = shift; my $user = shift || {}; 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 $target = { read => $Config::Config{sitearchexp}."/auto/$name/.packlist", write => $Config::Config{installsitearch}."/auto/$name/.packlist", $sources{inst_lib} => (_directory_not_empty($sources{inst_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}, }; foreach my $key (keys %$user) { my $value = $user->{$key}; if (not defined $value and $key ne 'packlist_read' and $key ne 'packlist_write') { delete $target->{ $sources{$key} }; } elsif (exists $sources{$key}) { $target->{ $sources{$key} } = $value; } } 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; 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."; } } my $old_cwd = Cwd::cwd(); (undef, my $base_dir) = _unzip_to_tmpdir( dist => $base_par, subdir => 'blib' ); my $blibdir = File::Spec->catdir($base_dir, 'blib'); File::Copy::move( File::Spec->catfile($blibdir, 'META.yml'), File::Spec->catfile($base_dir, 'META.yml') ); unlink File::Spec->catfile($blibdir, 'MANIFEST'); foreach my $par (@additional_pars) { chdir($old_cwd); (undef, my $add_dir) = _unzip_to_tmpdir( dist => $par ); my @files; my @dirs; 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 ); 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); } 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]); } 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()); chdir($old_cwd); File::Copy::move($resulting_par_file, $base_par); File::Path::rmtree([$base_dir]); } sub remove_man { my %args = &_args; my $par = $args{dist}; require Cwd; require File::Copy; require File::Path; require File::Find; 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."; } my $old_cwd = Cwd::cwd(); (undef, my $base_dir) = _unzip_to_tmpdir( dist => $par, subdir => 'blib' ); my $blibdir = File::Spec->catdir($base_dir, 'blib'); File::Copy::move( File::Spec->catfile($blibdir, 'META.yml'), File::Spec->catfile($base_dir, 'META.yml') ); 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; my $old_cwd = Cwd::cwd(); (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 = ; 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; 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) } 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(); } else { return if system(unzip => $dist, '-d', $path); } 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 { system(qw(zip -r), $dist, File::Spec->curdir) and die $!; } } sub _args { if (not @_) { @_ = (glob('*.par'))[0]; } @_ = (dist => @_) if @_ == 1; my %args = @_; $args{name} ||= $args{dist}; if (defined $args{name}) { $args{name} =~ s/^\w+:\/\///; my @elems = parse_dist_name($args{name}); if (defined $elems[0]) { $args{name} = $elems[0]; } else { $args{name} =~ s/^.*\/([^\/]+)$/$1/; $args{name} =~ s/^([0-9A-Za-z_-]+)-\d+\..+$/$1/; } } 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"; } if ($args{dist} and $args{dist} =~ m!^\w+://!) { $args{dist} = _fetch(dist => $args{dist}) } return %args; } 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 = ; 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 @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; my $old_cwd = Cwd::cwd(); (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; } 1;