1 package App::FatPacker;
4 use warnings FATAL => 'all';
8 use File::Find qw(find);
9 use File::Spec::Functions qw(
10 catdir splitpath splitdir catpath rel2abs abs2rel
13 use File::Copy qw(copy);
14 use File::Path qw(mkpath rmtree);
17 our $VERSION = '0.010_006'; # 0.10.6
19 $VERSION = eval $VERSION;
23 my ($args, $options) = @_;
25 local *ARGV = [ @{$args} ];
26 $self->{option_parser}->getoptions(@$options);
32 map +(chomp,$_)[1], do { local @ARGV = ($_[0]); <> };
37 $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
42 $_[1] && $_[1] eq '-run_script'
43 and return shift->new->run_script;
48 option_parser => Getopt::Long::Parser->new(
49 config => [ qw(require_order pass_through bundling no_auto_abbrev) ]
55 my ($self, $args) = @_;
56 my @args = $args ? @$args : @ARGV;
57 (my $cmd = shift @args || 'help') =~ s/-/_/g;
59 if (my $meth = $self->can("script_command_${cmd}")) {
62 die "No such command ${cmd}";
66 sub script_command_help {
67 print "Try `perldoc fatpack` for how to use me\n";
70 sub script_command_pack {
71 my ($self, $args) = @_;
73 my @modules = split /\r?\n/, $self->trace(args => $args);
74 my @packlists = $self->packlists_containing(\@modules);
76 my $base = catdir(cwd, 'fatlib');
77 $self->packlists_to_tree($base, \@packlists);
79 my $file = shift @$args;
80 print $self->fatpack_file($file);
83 sub script_command_trace {
84 my ($self, $args) = @_;
86 $args = $self->call_parser($args => [
88 'to-stderr' => \my $to_stderr,
89 'use=s' => \my @additional_use
92 die "Can't use to and to-stderr on same call" if $file && $to_stderr;
94 $file ||= 'fatpacker.trace';
96 if (!$to_stderr and -e $file) {
97 unlink $file or die "Couldn't remove old trace file: $!";
108 use => \@additional_use,
115 my ($self, %opts) = @_;
117 my $output = $opts{output};
118 my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]};
120 local $ENV{PERL5OPT} = join ' ',
121 ($ENV{PERL5OPT}||()), '-MApp::FatPacker::Trace='.$trace_opts;
123 my @args = @{$opts{args}||[]};
126 # user specified output target, JFDI
130 # no output target specified, slurp
131 open my $out_fh, "$^X @args |";
132 return do { local $/; <$out_fh> };
136 sub script_command_packlists_for {
137 my ($self, $args) = @_;
138 foreach my $pl ($self->packlists_containing($args)) {
143 sub packlists_containing {
144 my ($self, $targets) = @_;
145 my @targets = @$targets;
147 local @INC = ('lib', @INC);
148 foreach my $t (@targets) {
152 my @search = grep -d $_, map catdir($_, 'auto'), @INC;
157 return unless /[\\\/]\.packlist$/ && -f $_;
158 $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
161 my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
165 sub script_command_tree {
166 my ($self, $args) = @_;
167 my $base = catdir(cwd,'fatlib');
168 $self->packlists_to_tree($base, $args);
171 sub packlists_to_tree {
172 my ($self, $where, $packlists) = @_;
175 foreach my $pl (@$packlists) {
176 my ($vol, $dirs, $file) = splitpath $pl;
177 my @dir_parts = splitdir $dirs;
179 PART: foreach my $p (0 .. $#dir_parts) {
180 if ($dir_parts[$p] eq 'auto') {
181 # $p-2 normally since it's <wanted path>/$Config{archname}/auto but
182 # if the last bit is a number it's $Config{archname}/$version/auto
183 # so use $p-3 in that case
184 my $version_lib = 0+!!($dir_parts[$p-1] =~ /^[0-9.]+$/);
185 $pack_base = catpath $vol, catdir @dir_parts[0..$p-(2+$version_lib)];
189 die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
190 foreach my $source (lines_of $pl) {
191 # there is presumably a better way to do "is this under this base?"
192 # but if so, it's not obvious to me in File::Spec
193 next unless substr($source,0,length $pack_base) eq $pack_base;
194 my $target = rel2abs( abs2rel($source, $pack_base), $where );
195 my $target_dir = catpath((splitpath $target)[0,1]);
197 copy $source => $target;
202 sub script_command_file {
203 my ($self, $args) = @_;
204 my $file = shift @$args;
205 print $self->fatpack_file($file);
209 my ($self, $file) = @_;
213 if ( defined $file and -r $file ) {
214 ($shebang, $script) = $self->load_main_script($file);
217 my @dirs = $self->collect_dirs();
219 $self->collect_files($_, \%files) for @dirs;
221 return join "\n", $shebang, $self->fatpack_code(\%files), $script;
224 # This method can be overload in sub classes
225 # For example to skip POD
227 my ($self, $file) = @_;
229 local (@ARGV, $/) = ($file);
239 return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
243 my ($self, $dir, $files) = @_;
246 !/\.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;
247 $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
248 $self->load_file($File::Find::name);
252 sub load_main_script {
253 my ($self, $file) = @_;
254 open my $fh, "<", $file or die("Can't read $file: $!");
256 my $script = join "", <$fh>;
258 unless ( index($shebang, '#!') == 0 ) {
259 $script = $shebang . $script;
262 return ($shebang, $script);
266 return stripspace <<' END_START';
267 # This chunk of stuff was generated by App::FatPacker. To find the original
268 # file's code, look for the end of this BEGIN block or the string 'FATPACK'
275 return stripspace <<' END_END';
276 s/^ //mg for values %fatpacked;
278 my $class = 'FatPacked::'.(0+\%fatpacked);
280 *{"${class}::files"} = sub { keys %{$_[0]} };
283 *{"${class}::INC"} = sub {
284 if (my $fat = $_[0]{$_[1]}) {
286 my $last = length $fat;
288 return 0 if $pos == $last;
289 my $next = (1 + index $fat, "\n", $pos) || $last;
290 $_ .= substr $fat, $pos, $next - $pos;
299 *{"${class}::INC"} = sub {
300 if (my $fat = $_[0]{$_[1]}) {
301 open my $fh, '<', \$fat
302 or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
309 unshift @INC, bless \%fatpacked, $class;
310 } # END OF FATPACK CODE
315 my ($self, $files) = @_;
317 (my $stub = $_) =~ s/\.pm$//;
318 my $name = uc join '_', split '/', $stub;
319 my $data = $files->{$_}; $data =~ s/^/ /mg; $data =~ s/(?<!\n)\z/\n/;
320 '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
321 .qq!${data}${name}\n!;
324 return join "\n", $self->fatpack_start, @segments, $self->fatpack_end;
331 App::FatPacker - pack your dependencies onto your script file
335 $ fatpack pack myscript.pl >myscript.packed.pl
337 Or, with more step-by-step control:
339 $ fatpack trace myscript.pl
340 $ fatpack packlists-for `cat fatpacker.trace` >packlists
341 $ fatpack tree `cat packlists`
342 $ fatpack file myscript.pl >myscript.packed.pl
344 See the documentation for the L<fatpack> script itself for more information.
346 The programmatic API for this code is not yet fully decided, hence the 0.x
347 release version. Expect that to be cleaned up for 1.0.
351 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
355 Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=App-FatPacker>
356 (or L<bug-App-FatPacker@rt.cpan.org|mailto:bug-App-FatPacker@rt.cpan.org>).
358 You can normally also obtain assistance on irc, in #toolchain on irc.perl.org.
362 Matt S. Trout (mst) <mst@shadowcat.co.uk>
366 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
368 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
370 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
372 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
374 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
376 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
378 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
380 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
382 dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
384 djerius - Diab Jerius (cpan:DJERIUS) <djerius@cpan.org>
386 haarg - Graham Knop (cpan:HAARG> <haarg@haarg.org>
388 Many more people are probably owed thanks for ideas. Yet
389 another doc nit to fix.
393 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
398 This library is free software and may be distributed under the same terms