X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=207141faf653d9ee47a6a0fefa5d66caaba2ce80;hb=1f8ac8bda7fdeba9e9a8a4559de66635046c38ed;hp=0ec72c676ddb6e85d81e49bdb3aa8edd01840882;hpb=bb5ea74187d347fbee28edb73685cc5123d966f2;p=p5sagit%2FApp-FatPacker.git diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index 0ec72c6..207141f 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.009004'; # 0.9.4 +our $VERSION = '0.009016'; # 0.009.016 $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 { @@ -59,32 +67,68 @@ sub script_command_help { print "Try `perldoc fatpack` for how to use me\n"; } +sub script_command_pack { + my ($self, $args) = @_; + + my @modules = split /\r?\n/, $self->trace(args => $args); + my @packlists = $self->packlists_containing(\@modules); + + my $base = catdir(cwd, 'fatlib'); + $self->packlists_to_tree($base, \@packlists); + + my $file = shift @$args; + print $self->fatpack_file($file); +} + 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 $output = $opts{output}; + 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 +142,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 +165,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 +185,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; } } @@ -148,16 +194,22 @@ sub packlists_to_tree { sub script_command_file { my ($self, $args) = @_; my $file = shift @$args; + print $self->fatpack_file($file); +} + +sub fatpack_file { + my ($self, $file) = @_; my $cwd = cwd; - my @dirs = map rel2abs($_, $cwd), ('lib','fatlib'); + my @dirs = grep -d, map rel2abs($_, $cwd), ('lib','fatlib'); my %files; foreach my $dir (@dirs) { 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 { + !/\.pm$/ and warn "File ${File::Find::name} isn't a .pm file - can't pack this -- if you hoped we were going to, things may not be what you expected later\n" and return; + $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do { local (@ARGV, $/) = ($File::Find::name); <> }; + close ARGV; }, $dir); } my $start = stripspace <<' END_START'; @@ -171,6 +223,14 @@ sub script_command_file { unshift @INC, sub { if (my $fat = $fatpacked{$_[1]}) { + if ($] < 5.008) { + return sub { + return 0 unless length $fat; + $fat =~ s/^([^\n]*\n?)//; + $_ = $1; + return 1; + }; + } open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; @@ -187,25 +247,47 @@ sub script_command_file { '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n! .qq!${data}${name}\n!; } sort keys %files; - print join "\n", $start, @segments, $end; + my $shebang = ""; + my $script = ""; + if ( defined $file and -r $file ) { + open my $fh, "<", $file or die("Can't read $file: $!"); + $shebang = <$fh>; + $script = join "", <$fh>; + close $fh; + unless ( index($shebang, '#!') == 0 ) { + $script = $shebang . $script; + $shebang = ""; + } + } + return join "\n", $shebang, $start, @segments, $end, $script; } +=encoding UTF-8 + =head1 NAME App::FatPacker - pack your dependencies onto your script file =head1 SYNOPSIS + $ fatpack pack myscript.pl >myscript.packed.pl + +Or, with more step-by-step control: + $ fatpack trace myscript.pl $ fatpack packlists-for `cat fatpacker.trace` >packlists $ fatpack tree `cat packlists` - $ (fatpack file; cat myscript.pl) >myscript.packed.pl + $ fatpack file myscript.pl >myscript.packed.pl 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 SEE ALSO + +L
+ =head1 SUPPORT Your current best avenue is to come annoy annoy mst on #toolchain on @@ -217,7 +299,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 +331,4 @@ as perl itself. =cut 1; +