X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=3a0bf06f5cc2870b546119d30241eb3b1f73df2c;hb=7180ec197a68ca3fc5c1326db1504bc828f5b001;hp=439934181f0048b0ba673e5f5672977e945b0422;hpb=cc5db92a0bedaa07593dc91ef75babb9e1c2fb86;p=p5sagit%2FApp-FatPacker.git diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index 4399341..3a0bf06 100644 --- a/lib/App/FatPacker.pm +++ b/lib/App/FatPacker.pm @@ -2,29 +2,29 @@ package App::FatPacker; use strict; use warnings FATAL => 'all'; -use 5.008001; use Getopt::Long; use Cwd qw(cwd); 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.009012'; # 0.9.012 $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 +38,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 +68,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 +133,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 +156,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 +176,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 +192,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'; @@ -171,7 +209,16 @@ sub script_command_file { unshift @INC, sub { if (my $fat = $fatpacked{$_[1]}) { - open my $fh, '<', \$fat; + if ($] < 5.008) { + return sub { + return 0 unless length $fat; + $text =~ s/^([^\n]*\n?)//; + $_ = $1; + return 1; + }; + } + open my $fh, '<', \$fat + or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return @@ -189,6 +236,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 @@ -202,7 +251,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 @@ -216,7 +265,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 @@ -232,3 +297,4 @@ as perl itself. =cut 1; +