X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=d1645e2981a7cd06eb327d950bffa5c7745efd6e;hb=3932228e7f567260598326b6de53a7bad2079d27;hp=199427ac38ad4052ea8dfa1785fe27836c9fc990;hpb=6481e9bf8ae52d7ce53d9712d470db0fa0f29e9c;p=p5sagit%2FApp-FatPacker.git diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index 199427a..d1645e2 100644 --- a/lib/App/FatPacker.pm +++ b/lib/App/FatPacker.pm @@ -14,7 +14,7 @@ use File::Copy qw(copy); use File::Path qw(mkpath rmtree); use B qw(perlstring); -our $VERSION = '0.009015'; # 0.009.015 +our $VERSION = '0.010004'; # 0.10.4 $VERSION = eval $VERSION; @@ -32,17 +32,6 @@ sub lines_of { map +(chomp,$_)[1], do { local @ARGV = ($_[0]); <> }; } -sub maybe_shebang { - my ($file) = @_; - open my $in, "<", $file or die "$file: $!"; - my $head = <$in>; - if ($head =~ m/^#\!/) { - ($head, do { local $/; <$in> }); - } else { - ('', do { local $/; $head . <$in> }); - } -} - sub stripspace { my ($text) = @_; $text =~ /^(\s+)/ && $text =~ s/^$1//mg; @@ -88,8 +77,7 @@ sub script_command_pack { $self->packlists_to_tree($base, \@packlists); my $file = shift @$args; - my($head, $body) = maybe_shebang($file); - print $head, $self->fatpack_file($file), $body; + print $self->fatpack_file($file); } sub script_command_trace { @@ -129,7 +117,8 @@ sub trace { my $output = $opts{output}; my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]}; - local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$trace_opts; + local $ENV{PERL5OPT} = join ' ', + ($ENV{PERL5OPT}||()), '-MApp::FatPacker::Trace='.$trace_opts; my @args = @{$opts{args}||[]}; @@ -139,7 +128,7 @@ sub trace { return; } else { # no output target specified, slurp - open my $out_fh, '-|', $^X, @args; + open my $out_fh, "$^X @args |"; return do { local $/; <$out_fh> }; } } @@ -154,18 +143,22 @@ sub script_command_packlists_for { sub packlists_containing { my ($self, $targets) = @_; my @targets = @$targets; - foreach my $t (@targets) { - require $t; + { + local @INC = ('lib', @INC); + foreach my $t (@targets) { + require $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; } @@ -211,55 +204,119 @@ sub script_command_file { sub fatpack_file { my ($self, $file) = @_; - my $cwd = cwd; - my @dirs = grep -d, map rel2abs($_, $cwd), ('lib','fatlib'); + + 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{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do { - local (@ARGV, $/) = ($File::Find::name); <> - }; - close ARGV; - }, $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]}) { - if ($] < 5.008) { - return sub { - return 0 unless length $fat; - $fat =~ s/^([^\n]*\n?)//; - $_ = $1; - return 1; - }; + my $class = 'FatPacked::'.(0+\%fatpacked); + no strict 'refs'; + *{"${class}::files"} = sub { keys %{$_[0]} }; + + if ($] < 5.008) { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + return sub { + return 0 unless length $fat; + $fat =~ s/^([^\n]*\n?)//; + $_ = $1; + return 1; + }; + } + return; + }; + } + + 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; } - open my $fh, '<', \$fat - or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; - return $fh; - } - return - }; + 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 @@ -277,14 +334,11 @@ Or, with more step-by-step control: $ fatpack trace myscript.pl $ fatpack packlists-for `cat fatpacker.trace` >packlists $ fatpack tree `cat packlists` - $ (head -n1 myscript.pl |grep '^#!'; fatpack file; cat myscript.pl) >myscript.packed.pl - -The C code pulls out the Unix shebang -line, if there is one, and injects it at the start of the packed script. + $ 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 +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 SEE ALSO @@ -293,7 +347,7 @@ L
=head1 SUPPORT -Your current best avenue is to come annoy annoy mst on #toolchain on +Your current best avenue is to come annoy mst on #toolchain on irc.perl.org. There should be a non-IRC means of support by 1.0. =head1 AUTHOR @@ -318,6 +372,12 @@ 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> + Many more people are probably owed thanks for ideas. Yet another doc nit to fix.