95757b900f47450a39ece1ce743c33dceb66e2fa
[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.009013'; # 0.9.013
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_trace {
71   my ($self, $args) = @_;
72
73   $args = $self->call_parser($args => [
74     'to=s' => \my $file,
75     'to-stderr' => \my $to_stderr,
76     'use=s' => \my @additional_use
77   ]);
78
79   die "Can't use to and to-stderr on same call" if $file && $to_stderr;
80
81   $file ||= 'fatpacker.trace';
82
83   if (!$to_stderr and -e $file) {
84     unlink $file or die "Couldn't remove old trace file: $!";
85   }
86   my $arg = do {
87     if ($to_stderr) {
88       ">&STDERR"
89     } elsif ($file) {
90       ">>${file}"
91     }
92   };
93
94   $self->trace(
95     use => \@additional_use,
96     args => $args,
97     output => $arg,
98   );
99 }
100
101 sub trace {
102   my ($self, %opts) = @_;
103
104   my $capture;
105
106   my $output = $opts{output} || do {
107     $capture++; '>&STDOUT'
108   };
109
110   my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]};
111
112   local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$trace_opts;
113
114   my @args = @{$opts{args}||[]};
115
116   if ($output) {
117     # user specified output target, JFDI
118     system $^X, @args;
119     return;
120   } else {
121     # no output target specified, slurp
122     open my $out_fh, '-|', $^X, @args;
123     return do { local $/; <$out_fh> };
124   }
125 }
126
127 sub script_command_packlists_for {
128   my ($self, $args) = @_;
129   foreach my $pl ($self->packlists_containing($args)) {
130     print "${pl}\n";
131   }
132 }
133
134 sub packlists_containing {
135   my ($self, $targets) = @_;
136   my @targets = @$targets;
137   foreach my $t (@targets) {
138     require $t;
139   }
140   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
141   my %pack_rev;
142   my $cwd = cwd;
143   find(sub {
144     return unless $_ eq '.packlist' && -f $_;
145     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
146   }, @search);
147   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
148   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
149   sort keys %found;
150 }
151
152 sub script_command_tree {
153   my ($self, $args) = @_;
154   my $base = catdir(cwd,'fatlib');
155   $self->packlists_to_tree($base, $args);
156 }
157
158 sub packlists_to_tree {
159   my ($self, $where, $packlists) = @_;
160   rmtree $where;
161   mkpath $where;
162   foreach my $pl (@$packlists) {
163     my ($vol, $dirs, $file) = splitpath $pl;
164     my @dir_parts = splitdir $dirs;
165     my $pack_base;
166     PART: foreach my $p (0 .. $#dir_parts) {
167       if ($dir_parts[$p] eq 'auto') {
168         # $p-2 since it's <wanted path>/$Config{archname}/auto
169         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
170         last PART;
171       }
172     }
173     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
174     foreach my $source (lines_of $pl) {
175       # there is presumably a better way to do "is this under this base?"
176       # but if so, it's not obvious to me in File::Spec
177       next unless substr($source,0,length $pack_base) eq $pack_base;
178       my $target = rel2abs( abs2rel($source, $pack_base), $where );
179       my $target_dir = catpath((splitpath $target)[0,1]);
180       mkpath $target_dir;
181       copy $source => $target;
182     }
183   }
184 }
185
186 sub script_command_file {
187   my ($self, $args) = @_;
188   my $file = shift @$args;
189   my $cwd = cwd;
190   my @dirs = grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
191   my %files;
192   foreach my $dir (@dirs) {
193     find(sub {
194       return unless -f $_;
195       !/\.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;
196       $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do {
197         local (@ARGV, $/) = ($File::Find::name); <>
198       };
199       close ARGV;
200     }, $dir);
201   }
202   my $start = stripspace <<'  END_START';
203     # This chunk of stuff was generated by App::FatPacker. To find the original
204     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
205     BEGIN {
206     my %fatpacked;
207   END_START
208   my $end = stripspace <<'  END_END';
209     s/^  //mg for values %fatpacked;
210
211     unshift @INC, sub {
212       if (my $fat = $fatpacked{$_[1]}) {
213         if ($] < 5.008) {
214           return sub {
215             return 0 unless length $fat;
216             $fat =~ s/^([^\n]*\n?)//;
217             $_ = $1;
218             return 1;
219           };
220         }
221         open my $fh, '<', \$fat
222           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
223         return $fh;
224       }
225       return
226     };
227
228     } # END OF FATPACK CODE
229   END_END
230   my @segments = map {
231     (my $stub = $_) =~ s/\.pm$//;
232     my $name = uc join '_', split '/', $stub;
233     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
234     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
235     .qq!${data}${name}\n!;
236   } sort keys %files;
237   print join "\n", $start, @segments, $end;
238 }
239
240 =encoding UTF-8
241
242 =head1 NAME
243
244 App::FatPacker - pack your dependencies onto your script file
245
246 =head1 SYNOPSIS
247
248   $ fatpack trace myscript.pl
249   $ fatpack packlists-for `cat fatpacker.trace` >packlists
250   $ fatpack tree `cat packlists`
251   $ (head -n1 myscript.pl |grep '^#!'; fatpack file; cat myscript.pl) >myscript.packed.pl
252
253 The C<head -n1 myscript.pl |grep '^#!'> code pulls out the Unix shebang
254 line, if there is one, and injects it at the start of the packed script.
255
256 See the documentation for the L<fatpack> script itself for more information.
257
258 The programmatic API for this code is not yet fully decided, hence the 0.9
259 release version. Expect that to be cleaned up for 1.0.
260
261 =head1 SEE ALSO
262
263 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
264
265 =head1 SUPPORT
266
267 Your current best avenue is to come annoy annoy mst on #toolchain on
268 irc.perl.org. There should be a non-IRC means of support by 1.0.
269
270 =head1 AUTHOR
271
272 Matt S. Trout (mst) <mst@shadowcat.co.uk>
273
274 =head2 CONTRIBUTORS
275
276 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
277
278 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
279
280 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
281
282 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
283
284 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
285
286 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
287
288 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
289
290 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
291
292 Many more people are probably owed thanks for ideas. Yet
293 another doc nit to fix.
294
295 =head1 COPYRIGHT
296
297 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
298 as listed above.
299
300 =head1 LICENSE
301
302 This library is free software and may be distributed under the same terms
303 as perl itself.
304
305 =cut
306
307 1;
308