File Coverage

blib/lib/App/FatPacker.pm
Criterion Covered Total %
statement 83 175 47.4
branch 9 44 20.4
condition 4 30 13.3
subroutine 24 36 66.6
pod 0 22 0.0
total 120 307 39.0


line stmt bran cond sub pod time code
1             package App::FatPacker;
2              
3 3     3   186534 use strict;
  3         28  
  3         96  
4 3     3   16 use warnings FATAL => 'all';
  3         4  
  3         126  
5 3     3   58 use 5.008001;
  3         11  
6 3     3   2155 use Getopt::Long;
  3         32098  
  3         14  
7 3     3   475 use Cwd qw(cwd);
  3         5  
  3         139  
8 3     3   18 use File::Find qw(find);
  3         7  
  3         213  
9 3         256 use File::Spec::Functions qw(
10             catdir splitpath splitdir catpath rel2abs abs2rel
11 3     3   1475 );
  3         2475  
12 3     3   22 use File::Spec::Unix;
  3         6  
  3         74  
13 3     3   1020 use File::Copy qw(copy);
  3         4623  
  3         179  
14 3     3   23 use File::Path qw(mkpath rmtree);
  3         6  
  3         171  
15 3     3   19 use B qw(perlstring);
  3         5  
  3         7310  
16              
17             our $VERSION = '0.010008'; # v0.10.8
18              
19             $VERSION = eval $VERSION;
20              
21             sub call_parser {
22 0     0 0 0 my $self = shift;
23 0         0 my ($args, $options) = @_;
24              
25 0         0 local *ARGV = [ @{$args} ];
  0         0  
26 0         0 $self->{option_parser}->getoptions(@$options);
27              
28 0         0 return [ @ARGV ];
29             }
30              
31             sub lines_of {
32 0     0 0 0 map +(chomp,$_)[1], do { local @ARGV = ($_[0]); <> };
  0         0  
  0         0  
33             }
34              
35             sub stripspace {
36 4     4 0 25 my ($text) = @_;
37 4 50       139 $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
38 4         92 $text;
39             }
40              
41             sub import {
42 2 50 33 2   1968 $_[1] && $_[1] eq '-run_script'
43             and return shift->new->run_script;
44             }
45              
46             sub new {
47 2     2 0 2810 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 0     0 0 0 my ($self, $args) = @_;
56 0 0       0 my @args = $args ? @$args : @ARGV;
57 0   0     0 (my $cmd = shift @args || 'help') =~ s/-/_/g;
58              
59 0 0       0 if (my $meth = $self->can("script_command_${cmd}")) {
60 0         0 $self->$meth(\@args);
61             } else {
62 0         0 die "No such command ${cmd}";
63             }
64             }
65              
66             sub script_command_help {
67 0     0 0 0 print "Try `perldoc fatpack` for how to use me\n";
68             }
69              
70             sub script_command_pack {
71 0     0 0 0 my ($self, $args) = @_;
72              
73 0         0 my @modules = split /\r?\n/, $self->trace(args => $args);
74 0         0 my @packlists = $self->packlists_containing(\@modules);
75              
76 0         0 my $base = catdir(cwd, 'fatlib');
77 0         0 $self->packlists_to_tree($base, \@packlists);
78              
79 0         0 my $file = shift @$args;
80 0         0 print $self->fatpack_file($file);
81             }
82              
83             sub script_command_trace {
84 0     0 0 0 my ($self, $args) = @_;
85              
86 0         0 $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 0 0 0     0 die "Can't use to and to-stderr on same call" if $file && $to_stderr;
93              
94 0   0     0 $file ||= 'fatpacker.trace';
95              
96 0 0 0     0 if (!$to_stderr and -e $file) {
97 0 0       0 unlink $file or die "Couldn't remove old trace file: $!";
98             }
99 0         0 my $arg = do {
100 0 0       0 if ($to_stderr) {
    0          
101 0         0 ">&STDERR"
102             } elsif ($file) {
103 0         0 ">>${file}"
104             }
105             };
106              
107 0         0 $self->trace(
108             use => \@additional_use,
109             args => $args,
110             output => $arg,
111             );
112             }
113              
114             sub trace {
115 0     0 0 0 my ($self, %opts) = @_;
116              
117 0         0 my $output = $opts{output};
118 0 0 0     0 my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]};
  0         0  
119              
120             local $ENV{PERL5OPT} = join ' ',
121 0   0     0 ($ENV{PERL5OPT}||()), '-MApp::FatPacker::Trace='.$trace_opts;
122              
123 0 0       0 my @args = @{$opts{args}||[]};
  0         0  
124              
125 0 0       0 if ($output) {
126             # user specified output target, JFDI
127 0         0 system $^X, @args;
128 0         0 return;
129             } else {
130             # no output target specified, slurp
131 0         0 open my $out_fh, "$^X @args |";
132 0         0 return do { local $/; <$out_fh> };
  0         0  
  0         0  
133             }
134             }
135              
136             sub script_command_packlists_for {
137 0     0 0 0 my ($self, $args) = @_;
138 0         0 foreach my $pl ($self->packlists_containing($args)) {
139 0         0 print "${pl}\n";
140             }
141             }
142              
143             sub packlists_containing {
144 0     0 0 0 my ($self, $targets) = @_;
145 0         0 my @targets;
146             {
147 0         0 local @INC = ('lib', @INC);
  0         0  
148 0         0 foreach my $t (@$targets) {
149 0 0       0 unless (eval { require $t; 1}) {
  0         0  
  0         0  
150 0         0 warn "Failed to load ${t}: $@\n"
151             ."Make sure you're not missing a packlist as a result\n";
152 0         0 next;
153             }
154 0         0 push @targets, $t;
155             }
156             }
157 0         0 my @search = grep -d $_, map catdir($_, 'auto'), @INC;
158 0         0 my %pack_rev;
159             find({
160             no_chdir => 1,
161             wanted => sub {
162 0 0 0 0   0 return unless /[\\\/]\.packlist$/ && -f $_;
163 0         0 $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
164             },
165 0         0 }, @search);
166 0   0     0 my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
  0         0  
167 0         0 sort keys %found;
168             }
169              
170             sub script_command_tree {
171 0     0 0 0 my ($self, $args) = @_;
172 0         0 my $base = catdir(cwd,'fatlib');
173 0         0 $self->packlists_to_tree($base, $args);
174             }
175              
176             sub packlists_to_tree {
177 0     0 0 0 my ($self, $where, $packlists) = @_;
178 0         0 rmtree $where;
179 0         0 mkpath $where;
180 0         0 foreach my $pl (@$packlists) {
181 0         0 my ($vol, $dirs, $file) = splitpath $pl;
182 0         0 my @dir_parts = splitdir $dirs;
183 0         0 my $pack_base;
184 0         0 PART: foreach my $p (0 .. $#dir_parts) {
185 0 0       0 if ($dir_parts[$p] eq 'auto') {
186             # $p-2 normally since it's /$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 0         0 my $version_lib = 0+!!($dir_parts[$p-1] =~ /^[0-9.]+$/);
190 0         0 $pack_base = catpath $vol, catdir @dir_parts[0..$p-(2+$version_lib)];
191 0         0 last PART;
192             }
193             }
194 0 0       0 die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
195 0         0 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 0 0       0 next unless substr($source,0,length $pack_base) eq $pack_base;
199 0         0 my $target = rel2abs( abs2rel($source, $pack_base), $where );
200 0         0 my $target_dir = catpath((splitpath $target)[0,1]);
201 0         0 mkpath $target_dir;
202 0         0 copy $source => $target;
203             }
204             }
205             }
206              
207             sub script_command_file {
208 2     2 0 1345 my ($self, $args) = @_;
209 2         7 my $file = shift @$args;
210 2         7 print $self->fatpack_file($file);
211             }
212              
213             sub fatpack_file {
214 2     2 0 7 my ($self, $file) = @_;
215              
216 2         5 my $shebang = "";
217 2         3 my $script = "";
218 2 100 66     31 if ( defined $file and -r $file ) {
219 1         6 ($shebang, $script) = $self->load_main_script($file);
220             }
221              
222 2         9 my @dirs = $self->collect_dirs();
223 2         368 my %files;
224 2         45 $self->collect_files($_, \%files) for @dirs;
225              
226 2         26 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 6     6 0 16 my ($self, $file) = @_;
233 6         14 my $content = do {
234 6         40 local (@ARGV, $/) = ($file);
235             <>
236 6         334 };
237 6         55 close ARGV;
238 6         624 return $content;
239             }
240              
241             sub collect_dirs {
242 2     2 0 5 my ($self) = @_;
243 2         5838 my $cwd = cwd;
244 2         153 return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
245             }
246              
247             sub collect_files {
248 3     3 0 31 my ($self, $dir, $files) = @_;
249             find(sub {
250 10 100   10   595 return unless -f $_;
251 6 50 33     91 !/\.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 6         30 $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
253             $self->load_file($File::Find::name);
254 3         523 }, $dir);
255             }
256              
257             sub load_main_script {
258 1     1 0 4 my ($self, $file) = @_;
259 1 50       34 open my $fh, "<", $file or die("Can't read $file: $!");
260 1         15 my $shebang = <$fh>;
261 1         24 my $script = join "", <$fh>;
262 1         12 close $fh;
263 1 50       8 unless ( index($shebang, '#!') == 0 ) {
264 1         4 $script = $shebang . $script;
265 1         2 $shebang = "";
266             }
267 1         7 return ($shebang, $script);
268             }
269              
270             sub fatpack_start {
271 2     2 0 22 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 2     2 0 12 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 2     2 0 13 my ($self, $files) = @_;
321             my @segments = map {
322 2         26 (my $stub = $_) =~ s/\.pm$//;
  6         34  
323 6         27 my $name = uc join '_', split '/', $stub;
324 6         12 my $data = $files->{$_}; $data =~ s/^/ /mg; $data =~ s/(?
  6         46  
  6         24  
325 6         49 '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
326             .qq!${data}${name}\n!;
327             } sort keys %$files;
328              
329 2         10 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             Each command is designed to be simple and self-contained so that you can modify
350             the input/output of each step as needed. See the documentation for the
351             L script itself for more information.
352              
353             The programmatic API for this code is not yet fully decided, hence the 0.x
354             release version. Expect that to be cleaned up for 1.0.
355              
356             =head1 CAVEATS
357              
358             As dependency module code is copied into the resulting file as text, only
359             pure-perl dependencies can be packed, not compiled XS code.
360              
361             The currently-installed dependencies to pack are found via F<.packlist> files,
362             which are generally only included in non-core distributions that were installed
363             by a CPAN installer. This is a feature; see L for
364             details. (a notable exception to this is FreeBSD, which, since its packaging
365             system is designed to work equivalently to a source install, does preserve
366             the packlist files)
367              
368             =head1 SEE ALSO
369              
370             L
371              
372             L - PAR Packager, a much more complex architecture-dependent packer that
373             can pack compiled code and even a Perl interpreter
374              
375             =head1 SUPPORT
376              
377             Bugs may be submitted through L
378             (or L).
379              
380             You can normally also obtain assistance on irc, in #toolchain on irc.perl.org.
381              
382             =head1 AUTHOR
383              
384             Matt S. Trout (mst)
385              
386             =head2 CONTRIBUTORS
387              
388             miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA)
389              
390             tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM)
391              
392             dg - David Leadbeater (cpan:DGL)
393              
394             gugod - 劉康民 (cpan:GUGOD)
395              
396             t0m - Tomas Doran (cpan:BOBTFISH)
397              
398             sawyer - Sawyer X (cpan:XSAWYERX)
399              
400             ether - Karen Etheridge (cpan:ETHER)
401              
402             Mithaldu - Christian Walde (cpan:MITHALDU)
403              
404             dolmen - Olivier Mengué (cpan:DOLMEN)
405              
406             djerius - Diab Jerius (cpan:DJERIUS)
407              
408             haarg - Graham Knop (cpan:HAARG)
409              
410             grinnz - Dan Book (cpan:DBOOK)
411              
412             Many more people are probably owed thanks for ideas. Yet
413             another doc nit to fix.
414              
415             =head1 COPYRIGHT
416              
417             Copyright (c) 2010 the App::FatPacker L and L
418             as listed above.
419              
420             =head1 LICENSE
421              
422             This library is free software and may be distributed under the same terms
423             as perl itself.
424              
425             =cut
426              
427             1;
428