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.010000'; # 0.10.0
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} = '-MApp::FatPacker::Trace='.$trace_opts;
122 my @args = @{$opts{args}||[]};
125 # user specified output target, JFDI
129 # no output target specified, slurp
130 open my $out_fh, "$^X @args |";
131 return do { local $/; <$out_fh> };
135 sub script_command_packlists_for {
136 my ($self, $args) = @_;
137 foreach my $pl ($self->packlists_containing($args)) {
142 sub packlists_containing {
143 my ($self, $targets) = @_;
144 my @targets = @$targets;
145 foreach my $t (@targets) {
148 my @search = grep -d $_, map catdir($_, 'auto'), @INC;
153 return unless /[\\\/]\.packlist$/ && -f $_;
154 $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
157 my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
161 sub script_command_tree {
162 my ($self, $args) = @_;
163 my $base = catdir(cwd,'fatlib');
164 $self->packlists_to_tree($base, $args);
167 sub packlists_to_tree {
168 my ($self, $where, $packlists) = @_;
171 foreach my $pl (@$packlists) {
172 my ($vol, $dirs, $file) = splitpath $pl;
173 my @dir_parts = splitdir $dirs;
175 PART: foreach my $p (0 .. $#dir_parts) {
176 if ($dir_parts[$p] eq 'auto') {
177 # $p-2 since it's <wanted path>/$Config{archname}/auto
178 $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
182 die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
183 foreach my $source (lines_of $pl) {
184 # there is presumably a better way to do "is this under this base?"
185 # but if so, it's not obvious to me in File::Spec
186 next unless substr($source,0,length $pack_base) eq $pack_base;
187 my $target = rel2abs( abs2rel($source, $pack_base), $where );
188 my $target_dir = catpath((splitpath $target)[0,1]);
190 copy $source => $target;
195 sub script_command_file {
196 my ($self, $args) = @_;
197 my $file = shift @$args;
198 print $self->fatpack_file($file);
202 my ($self, $file) = @_;
206 if ( defined $file and -r $file ) {
207 ($shebang, $script) = $self->load_main_script($file);
210 my @dirs = $self->collect_dirs();
212 $self->collect_files($_, \%files) for @dirs;
214 return join "\n", $shebang, $self->fatpack_code(\%files), $script;
217 # This method can be overload in sub classes
218 # For example to skip POD
220 my ($self, $file) = @_;
222 local (@ARGV, $/) = ($file);
232 return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
236 my ($self, $dir, $files) = @_;
239 !/\.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;
240 $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
241 $self->load_file($File::Find::name);
245 sub load_main_script {
246 my ($self, $file) = @_;
247 open my $fh, "<", $file or die("Can't read $file: $!");
249 my $script = join "", <$fh>;
251 unless ( index($shebang, '#!') == 0 ) {
252 $script = $shebang . $script;
255 return ($shebang, $script);
259 return stripspace <<' END_START';
260 # This chunk of stuff was generated by App::FatPacker. To find the original
261 # file's code, look for the end of this BEGIN block or the string 'FATPACK'
268 return stripspace <<' END_END';
269 s/^ //mg for values %fatpacked;
271 my $class = 'FatPacked::'.(0+\%fatpacked);
273 *{"${class}::files"} = sub { keys %{$_[0]} };
276 *{"${class}::INC"} = sub {
277 if (my $fat = $_[0]{$_[1]}) {
279 return 0 unless length $fat;
280 $fat =~ s/^([^\n]*\n?)//;
290 *{"${class}::INC"} = sub {
291 if (my $fat = $_[0]{$_[1]}) {
292 open my $fh, '<', \$fat
293 or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
300 unshift @INC, bless \%fatpacked, $class;
301 } # END OF FATPACK CODE
306 my ($self, $files) = @_;
308 (my $stub = $_) =~ s/\.pm$//;
309 my $name = uc join '_', split '/', $stub;
310 my $data = $files->{$_}; $data =~ s/^/ /mg; $data =~ s/(?<!\n)\z/\n/;
311 '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
312 .qq!${data}${name}\n!;
315 return join "\n", $self->fatpack_start, @segments, $self->fatpack_end;
322 App::FatPacker - pack your dependencies onto your script file
326 $ fatpack pack myscript.pl >myscript.packed.pl
328 Or, with more step-by-step control:
330 $ fatpack trace myscript.pl
331 $ fatpack packlists-for `cat fatpacker.trace` >packlists
332 $ fatpack tree `cat packlists`
333 $ fatpack file myscript.pl >myscript.packed.pl
335 See the documentation for the L<fatpack> script itself for more information.
337 The programmatic API for this code is not yet fully decided, hence the 0.x
338 release version. Expect that to be cleaned up for 1.0.
342 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
346 Your current best avenue is to come annoy mst on #toolchain on
347 irc.perl.org. There should be a non-IRC means of support by 1.0.
351 Matt S. Trout (mst) <mst@shadowcat.co.uk>
355 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
357 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
359 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
361 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
363 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
365 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
367 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
369 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
371 dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
373 djerius - Diab Jerius (cpan:DJERIUS) <djerius@cpan.org>
375 haarg - Graham Knop (cpan:HAARG> <haarg@haarg.org>
377 Many more people are probably owed thanks for ideas. Yet
378 another doc nit to fix.
382 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
387 This library is free software and may be distributed under the same terms