X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=03d28fbf2dd5292f0f4f1ba717bca0b5a6f2d4ea;hb=bb49414d002fe7f1b61e57f961ebb6d1b246814d;hp=aa3caefffe9a9b3b011ffbd61907c7eaa86686cf;hpb=002ecfea279e0e4db46718a0b499f76155439e16;p=p5sagit%2FApp-FatPacker.git diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index aa3caef..03d28fb 100644 --- a/lib/App/FatPacker.pm +++ b/lib/App/FatPacker.pm @@ -9,22 +9,23 @@ use File::Find qw(find); use File::Spec::Functions qw( catdir splitpath splitdir catpath rel2abs abs2rel ); +use File::Spec::Unix; use File::Copy qw(copy); -use File::Path qw(make_path remove_tree); +use File::Path qw(mkpath rmtree); use B qw(perlstring); -our $VERSION = '0.009003'; # 0.9.3 +our $VERSION = '0.009009'; # 0.9.9 $VERSION = eval $VERSION; -my $option_parser = Getopt::Long::Parser->new( - config => [ qw(require_order pass_through bundling no_auto_abbrev) ] -); - sub call_parser { - local *ARGV = [ @{$_[0]} ]; - $option_parser->getoptions(@{$_[1]}); - [ @ARGV ]; + my $self = shift; + my ($args, $options) = @_; + + local *ARGV = [ @{$args} ]; + $self->{option_parser}->getoptions(@$options); + + return [ @ARGV ]; } sub lines_of { @@ -38,16 +39,23 @@ sub stripspace { } sub import { - $_[1] eq '-run_script' + $_[1] && $_[1] eq '-run_script' and return shift->new->run_script; } -sub new { bless({}, $_[0]) } +sub new { + bless { + option_parser => Getopt::Long::Parser->new( + config => [ qw(require_order pass_through bundling no_auto_abbrev) ] + ), + }, $_[0]; +} sub run_script { my ($self, $args) = @_; my @args = $args ? @$args : @ARGV; (my $cmd = shift @args || 'help') =~ s/-/_/g; + if (my $meth = $self->can("script_command_${cmd}")) { $self->$meth(\@args); } else { @@ -61,30 +69,58 @@ sub script_command_help { sub script_command_trace { my ($self, $args) = @_; - - $args = call_parser $args => [ + + $args = $self->call_parser($args => [ 'to=s' => \my $file, 'to-stderr' => \my $to_stderr, - ]; + 'use=s' => \my @additional_use + ]); die "Can't use to and to-stderr on same call" if $file && $to_stderr; - (my $use_file = $file) ||= 'fatpacker.trace'; - if (!$to_stderr and -e $use_file) { - unlink $use_file or die "Couldn't remove old trace file: $!"; + $file ||= 'fatpacker.trace'; + + if (!$to_stderr and -e $file) { + unlink $file or die "Couldn't remove old trace file: $!"; } my $arg = do { - if ($file) { - "=>>${file}" - } elsif ($to_stderr) { - "=>&STDERR" - } else { - "" + if ($to_stderr) { + ">&STDERR" + } elsif ($file) { + ">>${file}" } }; - { - local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace'.$arg; - system $^X, @$args; + + $self->trace( + use => \@additional_use, + args => $args, + output => $arg, + ); +} + +sub trace { + my ($self, %opts) = @_; + + my $capture; + + my $output = $opts{output} || do { + $capture++; '>&STDOUT' + }; + + my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]}; + + local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$trace_opts; + + my @args = @{$opts{args}||[]}; + + if ($output) { + # user specified output target, JFDI + system $^X, @args; + return; + } else { + # no output target specified, slurp + open my $out_fh, '-|', $^X, @args; + return do { local $/; <$out_fh> }; } } @@ -98,7 +134,9 @@ sub script_command_packlists_for { sub packlists_containing { my ($self, $targets) = @_; my @targets = @$targets; - require $_ for @targets; + foreach my $t (@targets) { + require $t; + } my @search = grep -d $_, map catdir($_, 'auto'), @INC; my %pack_rev; my $cwd = cwd; @@ -119,8 +157,8 @@ sub script_command_tree { sub packlists_to_tree { my ($self, $where, $packlists) = @_; - remove_tree $where; - make_path $where; + rmtree $where; + mkpath $where; foreach my $pl (@$packlists) { my ($vol, $dirs, $file) = splitpath $pl; my @dir_parts = splitdir $dirs; @@ -139,7 +177,7 @@ sub packlists_to_tree { next unless substr($source,0,length $pack_base) eq $pack_base; my $target = rel2abs( abs2rel($source, $pack_base), $where ); my $target_dir = catpath((splitpath $target)[0,1]); - make_path $target_dir; + mkpath $target_dir; copy $source => $target; } } @@ -155,9 +193,10 @@ sub script_command_file { find(sub { return unless -f $_; !/\.pm$/ and warn "File ${File::Find::name} isn't a .pm file - can't pack this and if you hoped we were going to things may not be what you expected later\n" and return; - $files{abs2rel($File::Find::name,$dir)} = do { + $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do { local (@ARGV, $/) = ($File::Find::name); <> }; + close ARGV; }, $dir); } my $start = stripspace <<' END_START'; @@ -190,6 +229,8 @@ sub script_command_file { print join "\n", $start, @segments, $end; } +=encoding UTF-8 + =head1 NAME App::FatPacker - pack your dependencies onto your script file @@ -203,7 +244,7 @@ App::FatPacker - pack your dependencies onto your script file See the documentation for the L script itself for more information. -The programmatic API for this code is not yet fully decided, hence the 0.9.1 +The programmatic API for this code is not yet fully decided, hence the 0.9 release version. Expect that to be cleaned up for 1.0. =head1 SUPPORT @@ -217,7 +258,23 @@ Matt S. Trout (mst) =head2 CONTRIBUTORS -None as yet, though I probably owe lots of people thanks for ideas. Yet +miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) + +tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) + +dg - David Leadbeater (cpan:DGL) + +gugod - 劉康民 (cpan:GUGOD) + +t0m - Tomas Doran (cpan:BOBTFISH) + +sawyer - Sawyer X (cpan:XSAWYERX) + +ether - Karen Etheridge (cpan:ETHER) + +Mithaldu - Christian Walde (cpan:MITHALDU) + +Many more people are probably owed thanks for ideas. Yet another doc nit to fix. =head1 COPYRIGHT @@ -233,3 +290,4 @@ as perl itself. =cut 1; +