bump version
[p5sagit/App-FatPacker.git] / lib / App / FatPacker.pm
1 package App::FatPacker;
2
3 use strict;
4 use warnings FATAL => 'all';
5 use 5.008001;
6 use Getopt::Long;
7 use Cwd qw(cwd);
8 use File::Find qw(find);
9 use File::Spec::Functions qw(
10   catdir splitpath splitdir catpath rel2abs abs2rel
11 );
12 use File::Spec::Unix;
13 use File::Copy qw(copy);
14 use File::Path qw(mkpath rmtree);
15 use B qw(perlstring);
16
17 our $VERSION = '0.010007'; # 0.10.7
18
19 $VERSION = eval $VERSION;
20
21 sub call_parser {
22   my $self = shift;
23   my ($args, $options) = @_;
24
25   local *ARGV = [ @{$args} ];
26   $self->{option_parser}->getoptions(@$options);
27
28   return [ @ARGV ];
29 }
30
31 sub lines_of {
32   map +(chomp,$_)[1], do { local @ARGV = ($_[0]); <> };
33 }
34
35 sub stripspace {
36   my ($text) = @_;
37   $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
38   $text;
39 }
40
41 sub import {
42   $_[1] && $_[1] eq '-run_script'
43     and return shift->new->run_script;
44 }
45
46 sub new {
47   bless {
48     option_parser => Getopt::Long::Parser->new(
49       config => [ qw(require_order pass_through bundling no_auto_abbrev) ]
50     ),
51   }, $_[0];
52 }
53
54 sub run_script {
55   my ($self, $args) = @_;
56   my @args = $args ? @$args : @ARGV;
57   (my $cmd = shift @args || 'help') =~ s/-/_/g;
58
59   if (my $meth = $self->can("script_command_${cmd}")) {
60     $self->$meth(\@args);
61   } else {
62     die "No such command ${cmd}";
63   }
64 }
65
66 sub script_command_help {
67   print "Try `perldoc fatpack` for how to use me\n";
68 }
69
70 sub script_command_pack {
71   my ($self, $args) = @_;
72
73   my @modules = split /\r?\n/, $self->trace(args => $args);
74   my @packlists = $self->packlists_containing(\@modules);
75
76   my $base = catdir(cwd, 'fatlib');
77   $self->packlists_to_tree($base, \@packlists);
78
79   my $file = shift @$args;
80   print $self->fatpack_file($file);
81 }
82
83 sub script_command_trace {
84   my ($self, $args) = @_;
85
86   $args = $self->call_parser($args => [
87     'to=s' => \my $file,
88     'to-stderr' => \my $to_stderr,
89     'use=s' => \my @additional_use
90   ]);
91
92   die "Can't use to and to-stderr on same call" if $file && $to_stderr;
93
94   $file ||= 'fatpacker.trace';
95
96   if (!$to_stderr and -e $file) {
97     unlink $file or die "Couldn't remove old trace file: $!";
98   }
99   my $arg = do {
100     if ($to_stderr) {
101       ">&STDERR"
102     } elsif ($file) {
103       ">>${file}"
104     }
105   };
106
107   $self->trace(
108     use => \@additional_use,
109     args => $args,
110     output => $arg,
111   );
112 }
113
114 sub trace {
115   my ($self, %opts) = @_;
116
117   my $output = $opts{output};
118   my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]};
119
120   local $ENV{PERL5OPT} = join ' ',
121     ($ENV{PERL5OPT}||()), '-MApp::FatPacker::Trace='.$trace_opts;
122
123   my @args = @{$opts{args}||[]};
124
125   if ($output) {
126     # user specified output target, JFDI
127     system $^X, @args;
128     return;
129   } else {
130     # no output target specified, slurp
131     open my $out_fh, "$^X @args |";
132     return do { local $/; <$out_fh> };
133   }
134 }
135
136 sub script_command_packlists_for {
137   my ($self, $args) = @_;
138   foreach my $pl ($self->packlists_containing($args)) {
139     print "${pl}\n";
140   }
141 }
142
143 sub packlists_containing {
144   my ($self, $targets) = @_;
145   my @targets;
146   {
147     local @INC = ('lib', @INC);
148     foreach my $t (@$targets) {
149       unless (eval { require $t; 1}) {
150         warn "Failed to load ${t}: $@\n"
151             ."Make sure you're not missing a packlist as a result\n";
152         next;
153       }
154       push @targets, $t;
155     }
156   }
157   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
158   my %pack_rev;
159   find({
160     no_chdir => 1,
161     wanted => sub {
162       return unless /[\\\/]\.packlist$/ && -f $_;
163       $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
164     },
165   }, @search);
166   my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
167   sort keys %found;
168 }
169
170 sub script_command_tree {
171   my ($self, $args) = @_;
172   my $base = catdir(cwd,'fatlib');
173   $self->packlists_to_tree($base, $args);
174 }
175
176 sub packlists_to_tree {
177   my ($self, $where, $packlists) = @_;
178   rmtree $where;
179   mkpath $where;
180   foreach my $pl (@$packlists) {
181     my ($vol, $dirs, $file) = splitpath $pl;
182     my @dir_parts = splitdir $dirs;
183     my $pack_base;
184     PART: foreach my $p (0 .. $#dir_parts) {
185       if ($dir_parts[$p] eq 'auto') {
186         # $p-2 normally since it's <wanted path>/$Config{archname}/auto but
187         # if the last bit is a number it's $Config{archname}/$version/auto
188         # so use $p-3 in that case
189         my $version_lib = 0+!!($dir_parts[$p-1] =~ /^[0-9.]+$/);
190         $pack_base = catpath $vol, catdir @dir_parts[0..$p-(2+$version_lib)];
191         last PART;
192       }
193     }
194     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
195     foreach my $source (lines_of $pl) {
196       # there is presumably a better way to do "is this under this base?"
197       # but if so, it's not obvious to me in File::Spec
198       next unless substr($source,0,length $pack_base) eq $pack_base;
199       my $target = rel2abs( abs2rel($source, $pack_base), $where );
200       my $target_dir = catpath((splitpath $target)[0,1]);
201       mkpath $target_dir;
202       copy $source => $target;
203     }
204   }
205 }
206
207 sub script_command_file {
208   my ($self, $args) = @_;
209   my $file = shift @$args;
210   print $self->fatpack_file($file);
211 }
212
213 sub fatpack_file {
214   my ($self, $file) = @_;
215
216   my $shebang = "";
217   my $script = "";
218   if ( defined $file and -r $file ) {
219     ($shebang, $script) = $self->load_main_script($file);
220   }
221
222   my @dirs = $self->collect_dirs();
223   my %files;
224   $self->collect_files($_, \%files) for @dirs;
225
226   return join "\n", $shebang, $self->fatpack_code(\%files), $script;
227 }
228
229 # This method can be overload in sub classes
230 # For example to skip POD
231 sub load_file {
232   my ($self, $file) = @_;
233   my $content = do {
234     local (@ARGV, $/) = ($file);
235     <>
236   };
237   close ARGV;
238   return $content;
239 }
240
241 sub collect_dirs {
242   my ($self) = @_;
243   my $cwd = cwd;
244   return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
245 }
246
247 sub collect_files {
248   my ($self, $dir, $files) = @_;
249   find(sub {
250     return unless -f $_;
251     !/\.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;
252     $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
253       $self->load_file($File::Find::name);
254   }, $dir);
255 }
256
257 sub load_main_script {
258   my ($self, $file) = @_;
259   open my $fh, "<", $file or die("Can't read $file: $!");
260   my $shebang = <$fh>;
261   my $script = join "", <$fh>;
262   close $fh;
263   unless ( index($shebang, '#!') == 0 ) {
264     $script = $shebang . $script;
265     $shebang = "";
266   }
267   return ($shebang, $script);
268 }
269
270 sub fatpack_start {
271   return stripspace <<'  END_START';
272     # This chunk of stuff was generated by App::FatPacker. To find the original
273     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
274     BEGIN {
275     my %fatpacked;
276   END_START
277 }
278
279 sub fatpack_end {
280   return stripspace <<'  END_END';
281     s/^  //mg for values %fatpacked;
282
283     my $class = 'FatPacked::'.(0+\%fatpacked);
284     no strict 'refs';
285     *{"${class}::files"} = sub { keys %{$_[0]} };
286
287     if ($] < 5.008) {
288       *{"${class}::INC"} = sub {
289         if (my $fat = $_[0]{$_[1]}) {
290           my $pos = 0;
291           my $last = length $fat;
292           return (sub {
293             return 0 if $pos == $last;
294             my $next = (1 + index $fat, "\n", $pos) || $last;
295             $_ .= substr $fat, $pos, $next - $pos;
296             $pos = $next;
297             return 1;
298           });
299         }
300       };
301     }
302
303     else {
304       *{"${class}::INC"} = sub {
305         if (my $fat = $_[0]{$_[1]}) {
306           open my $fh, '<', \$fat
307             or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
308           return $fh;
309         }
310         return;
311       };
312     }
313
314     unshift @INC, bless \%fatpacked, $class;
315   } # END OF FATPACK CODE
316   END_END
317 }
318
319 sub fatpack_code {
320   my ($self, $files) = @_;
321   my @segments = map {
322     (my $stub = $_) =~ s/\.pm$//;
323     my $name = uc join '_', split '/', $stub;
324     my $data = $files->{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
325     '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
326     .qq!${data}${name}\n!;
327   } sort keys %$files;
328
329   return join "\n", $self->fatpack_start, @segments, $self->fatpack_end;
330 }
331
332 =encoding UTF-8
333
334 =head1 NAME
335
336 App::FatPacker - pack your dependencies onto your script file
337
338 =head1 SYNOPSIS
339
340   $ fatpack pack myscript.pl >myscript.packed.pl
341
342 Or, with more step-by-step control:
343
344   $ fatpack trace myscript.pl
345   $ fatpack packlists-for `cat fatpacker.trace` >packlists
346   $ fatpack tree `cat packlists`
347   $ fatpack file myscript.pl >myscript.packed.pl
348
349 See the documentation for the L<fatpack> script itself for more information.
350
351 The programmatic API for this code is not yet fully decided, hence the 0.x
352 release version. Expect that to be cleaned up for 1.0.
353
354 =head1 SEE ALSO
355
356 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
357
358 =head1 SUPPORT
359
360 Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=App-FatPacker>
361 (or L<bug-App-FatPacker@rt.cpan.org|mailto:bug-App-FatPacker@rt.cpan.org>).
362
363 You can normally also obtain assistance on irc, in #toolchain on irc.perl.org.
364
365 =head1 AUTHOR
366
367 Matt S. Trout (mst) <mst@shadowcat.co.uk>
368
369 =head2 CONTRIBUTORS
370
371 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
372
373 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
374
375 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
376
377 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
378
379 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
380
381 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
382
383 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
384
385 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
386
387 dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
388
389 djerius - Diab Jerius (cpan:DJERIUS) <djerius@cpan.org>
390
391 haarg - Graham Knop (cpan:HAARG> <haarg@haarg.org>
392
393 Many more people are probably owed thanks for ideas. Yet
394 another doc nit to fix.
395
396 =head1 COPYRIGHT
397
398 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
399 as listed above.
400
401 =head1 LICENSE
402
403 This library is free software and may be distributed under the same terms
404 as perl itself.
405
406 =cut
407
408 1;
409