X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FApp-FatPacker.git;a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=e376e6f4244fac9a1e04e7c330f0f97c832b4fb4;hp=c225ac7167058df0dcb8baf7f1610694bf6feb34;hb=d1f34abed80b8760b5d6441168997b5fd1f72251;hpb=5e1de95d70751d027dc61d599c4e2eb7d437028d diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index c225ac7..e376e6f 100644 --- a/lib/App/FatPacker.pm +++ b/lib/App/FatPacker.pm @@ -4,26 +4,26 @@ use strict; use warnings FATAL => 'all'; use 5.008001; use Getopt::Long; -use Capture::Tiny (); 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(mkpath rmtree); use B qw(perlstring); -our $VERSION = '0.009006'; # 0.9.6 +our $VERSION = '0.010008'; # v0.10.8 $VERSION = eval $VERSION; sub call_parser { my $self = shift; - my ( $args, $options ) = @_; + my ($args, $options) = @_; local *ARGV = [ @{$args} ]; - $self->{'option_parser'}->getoptions( @{$options} ); + $self->{option_parser}->getoptions(@$options); return [ @ARGV ]; } @@ -67,24 +67,38 @@ 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 = $self->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; $file ||= 'fatpacker.trace'; + if (!$to_stderr and -e $file) { unlink $file or die "Couldn't remove old trace file: $!"; } my $arg = do { if ($to_stderr) { - "=&STDERR" + ">&STDERR" } elsif ($file) { ">>${file}" } @@ -99,39 +113,24 @@ sub script_command_trace { sub trace { my ($self, %opts) = @_; - my $use = defined $opts{'use'} ? $opts{'use'} : []; - my $args = defined $opts{'args'} ? $opts{'args'} : []; - my $output = $opts{'output'}; - my $capture; - - # if the user doesn't provide output, they want to actually - # capture the output and receive it back - if (!$output) { - # throw to STDOUT to differ from STDERR - $output .= '>&STDOUT'; - - # raise capture flag - $capture++; - } - if(@$use) { - $output .= "," . join ",", @$use; - } + my $output = $opts{output}; + my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]}; - my $trace_sub = sub { - local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$output; - system $^X, @$args; - }; + local $ENV{PERL5OPT} = join ' ', + ($ENV{PERL5OPT}||()), '-MApp::FatPacker::Trace='.$trace_opts; + + my @args = @{$opts{args}||[]}; - if ($capture) { - # capture both STDOUT and STDERR so we could throw away STDERR - # STDOUT will contain the trace - # STDERR will contain the "syntax OK" statement - my ($stdout, $stderr) = Capture::Tiny::capture {$trace_sub->()}; - return $stdout; + if ($output) { + # user specified output target, JFDI + system $^X, @args; + return; } else { - $trace_sub->(); - } + # no output target specified, slurp + open my $out_fh, "$^X @args |"; + return do { local $/; <$out_fh> }; + } } sub script_command_packlists_for { @@ -143,17 +142,28 @@ sub script_command_packlists_for { sub packlists_containing { my ($self, $targets) = @_; - my @targets = @$targets; - require $_ for @targets; + my @targets; + { + local @INC = ('lib', @INC); + foreach my $t (@$targets) { + unless (eval { require $t; 1}) { + warn "Failed to load ${t}: $@\n" + ."Make sure you're not missing a packlist as a result\n"; + next; + } + push @targets, $t; + } + } my @search = grep -d $_, map catdir($_, 'auto'), @INC; my %pack_rev; - my $cwd = cwd; - find(sub { - return unless $_ eq '.packlist' && -f $_; - $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name; + find({ + no_chdir => 1, + wanted => sub { + return unless /[\\\/]\.packlist$/ && -f $_; + $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name; + }, }, @search); - chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!"; - my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = (); + my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = (); sort keys %found; } @@ -173,8 +183,11 @@ sub packlists_to_tree { my $pack_base; PART: foreach my $p (0 .. $#dir_parts) { if ($dir_parts[$p] eq 'auto') { - # $p-2 since it's /$Config{archname}/auto - $pack_base = catpath $vol, catdir @dir_parts[0..$p-2]; + # $p-2 normally since it's /$Config{archname}/auto but + # if the last bit is a number it's $Config{archname}/$version/auto + # so use $p-3 in that case + my $version_lib = 0+!!($dir_parts[$p-1] =~ /^[0-9.]+$/); + $pack_base = catpath $vol, catdir @dir_parts[0..$p-(2+$version_lib)]; last PART; } } @@ -194,68 +207,177 @@ sub packlists_to_tree { sub script_command_file { my ($self, $args) = @_; my $file = shift @$args; - my $cwd = cwd; - my @dirs = map rel2abs($_, $cwd), ('lib','fatlib'); + print $self->fatpack_file($file); +} + +sub fatpack_file { + my ($self, $file) = @_; + + my $shebang = ""; + my $script = ""; + if ( defined $file and -r $file ) { + ($shebang, $script) = $self->load_main_script($file); + } + + my @dirs = $self->collect_dirs(); 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 { - local (@ARGV, $/) = ($File::Find::name); <> - }; - }, $dir); + $self->collect_files($_, \%files) for @dirs; + + return join "\n", $shebang, $self->fatpack_code(\%files), $script; +} + +# This method can be overload in sub classes +# For example to skip POD +sub load_file { + my ($self, $file) = @_; + my $content = do { + local (@ARGV, $/) = ($file); + <> + }; + close ARGV; + return $content; +} + +sub collect_dirs { + my ($self) = @_; + my $cwd = cwd; + return grep -d, map rel2abs($_, $cwd), ('lib','fatlib'); +} + +sub collect_files { + my ($self, $dir, $files) = @_; + find(sub { + return unless -f $_; + !/\.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)} = + $self->load_file($File::Find::name); + }, $dir); +} + +sub load_main_script { + my ($self, $file) = @_; + open my $fh, "<", $file or die("Can't read $file: $!"); + my $shebang = <$fh>; + my $script = join "", <$fh>; + close $fh; + unless ( index($shebang, '#!') == 0 ) { + $script = $shebang . $script; + $shebang = ""; } - my $start = stripspace <<' END_START'; + return ($shebang, $script); +} + +sub fatpack_start { + return stripspace <<' END_START'; # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; END_START - my $end = stripspace <<' END_END'; +} + +sub fatpack_end { + return stripspace <<' END_END'; s/^ //mg for values %fatpacked; - unshift @INC, sub { - if (my $fat = $fatpacked{$_[1]}) { - open my $fh, '<', \$fat - or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; - return $fh; - } - return - }; + my $class = 'FatPacked::'.(0+\%fatpacked); + no strict 'refs'; + *{"${class}::files"} = sub { keys %{$_[0]} }; + + if ($] < 5.008) { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + my $pos = 0; + my $last = length $fat; + return (sub { + return 0 if $pos == $last; + my $next = (1 + index $fat, "\n", $pos) || $last; + $_ .= substr $fat, $pos, $next - $pos; + $pos = $next; + return 1; + }); + } + }; + } + + else { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + open my $fh, '<', \$fat + or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; + return $fh; + } + return; + }; + } - } # END OF FATPACK CODE + unshift @INC, bless \%fatpacked, $class; + } # END OF FATPACK CODE END_END +} + +sub fatpack_code { + my ($self, $files) = @_; my @segments = map { (my $stub = $_) =~ s/\.pm$//; my $name = uc join '_', split '/', $stub; - my $data = $files{$_}; $data =~ s/^/ /mg; $data =~ s/(?{$_}; $data =~ s/^/ /mg; $data =~ s/(?fatpack_start, @segments, $self->fatpack_end; } +=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. +Each command is designed to be simple and self-contained so that you can modify +the input/output of each step as needed. 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 +The programmatic API for this code is not yet fully decided, hence the 0.x release version. Expect that to be cleaned up for 1.0. +=head1 CAVEATS + +As dependency module code is copied into the resulting file as text, only +pure-perl dependencies can be packed, not compiled XS code. + +The currently-installed dependencies to pack are found via F<.packlist> files, +which are generally only included in non-core distributions that were installed +by a CPAN installer. This is a feature; see L for +details. (a notable exception to this is FreeBSD, which, since its packaging +system is designed to work equivalently to a source install, does preserve +the packlist files) + +=head1 SEE ALSO + +L
+ +L - PAR Packager, a much more complex architecture-dependent packer that +can pack compiled code and even a Perl interpreter + =head1 SUPPORT -Your current best avenue is to come annoy annoy mst on #toolchain on -irc.perl.org. There should be a non-IRC means of support by 1.0. +Bugs may be submitted through L +(or L). + +You can normally also obtain assistance on irc, in #toolchain on irc.perl.org. =head1 AUTHOR @@ -263,7 +385,31 @@ 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) + +dolmen - Olivier Mengué (cpan:DOLMEN) + +djerius - Diab Jerius (cpan:DJERIUS) + +haarg - Graham Knop (cpan:HAARG) + +grinnz - Dan Book (cpan:DBOOK) + +Many more people are probably owed thanks for ideas. Yet another doc nit to fix. =head1 COPYRIGHT