File Coverage

blib/lib/App/FatPacker.pm
Criterion Covered Total %
statement 83 170 48.8
branch 9 42 21.4
condition 4 30 13.3
subroutine 24 36 66.6
pod 0 22 0.0
total 120 300 40.0


line stmt bran cond sub pod time code
1             package App::FatPacker;
2              
3 3     3   60301 use strict;
  3         5  
  3         72  
4 3     3   8 use warnings FATAL => 'all';
  3         4  
  3         85  
5 3     3   45 use 5.008001;
  3         6  
6 3     3   1893 use Getopt::Long;
  3         21076  
  3         9  
7 3     3   313 use Cwd qw(cwd);
  3         3  
  3         107  
8 3     3   10 use File::Find qw(find);
  3         2  
  3         131  
9 3         169 use File::Spec::Functions qw(
10             catdir splitpath splitdir catpath rel2abs abs2rel
11 3     3   1215 );
  3         1542  
12 3     3   12 use File::Spec::Unix;
  3         3  
  3         53  
13 3     3   817 use File::Copy qw(copy);
  3         3443  
  3         134  
14 3     3   20 use File::Path qw(mkpath rmtree);
  3         3  
  3         113  
15 3     3   10 use B qw(perlstring);
  3         1  
  3         4863  
16              
17             our $VERSION = '0.010_006'; # 0.10.6
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 7 my ($text) = @_;
37 4 50       77 $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
38 4         41 $text;
39             }
40              
41             sub import {
42 2 50 33 2   1212 $_[1] && $_[1] eq '-run_script'
43             and return shift->new->run_script;
44             }
45              
46             sub new {
47 2     2 0 2254 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 = @$targets;
146             {
147 0         0 local @INC = ('lib', @INC);
  0         0  
148 0         0 foreach my $t (@targets) {
149 0         0 require $t;
150             }
151             }
152 0         0 my @search = grep -d $_, map catdir($_, 'auto'), @INC;
153 0         0 my %pack_rev;
154             find({
155             no_chdir => 1,
156             wanted => sub {
157 0 0 0 0   0 return unless /[\\\/]\.packlist$/ && -f $_;
158 0         0 $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
159             },
160 0         0 }, @search);
161 0   0     0 my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
  0         0  
162 0         0 sort keys %found;
163             }
164              
165             sub script_command_tree {
166 0     0 0 0 my ($self, $args) = @_;
167 0         0 my $base = catdir(cwd,'fatlib');
168 0         0 $self->packlists_to_tree($base, $args);
169             }
170              
171             sub packlists_to_tree {
172 0     0 0 0 my ($self, $where, $packlists) = @_;
173 0         0 rmtree $where;
174 0         0 mkpath $where;
175 0         0 foreach my $pl (@$packlists) {
176 0         0 my ($vol, $dirs, $file) = splitpath $pl;
177 0         0 my @dir_parts = splitdir $dirs;
178 0         0 my $pack_base;
179 0         0 PART: foreach my $p (0 .. $#dir_parts) {
180 0 0       0 if ($dir_parts[$p] eq 'auto') {
181             # $p-2 normally since it's /$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 0         0 my $version_lib = 0+!!($dir_parts[$p-1] =~ /^[0-9.]+$/);
185 0         0 $pack_base = catpath $vol, catdir @dir_parts[0..$p-(2+$version_lib)];
186 0         0 last PART;
187             }
188             }
189 0 0       0 die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
190 0         0 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 0 0       0 next unless substr($source,0,length $pack_base) eq $pack_base;
194 0         0 my $target = rel2abs( abs2rel($source, $pack_base), $where );
195 0         0 my $target_dir = catpath((splitpath $target)[0,1]);
196 0         0 mkpath $target_dir;
197 0         0 copy $source => $target;
198             }
199             }
200             }
201              
202             sub script_command_file {
203 2     2 0 976 my ($self, $args) = @_;
204 2         4 my $file = shift @$args;
205 2         9 print $self->fatpack_file($file);
206             }
207              
208             sub fatpack_file {
209 2     2 0 3 my ($self, $file) = @_;
210              
211 2         3 my $shebang = "";
212 2         4 my $script = "";
213 2 100 66     22 if ( defined $file and -r $file ) {
214 1         4 ($shebang, $script) = $self->load_main_script($file);
215             }
216              
217 2         7 my @dirs = $self->collect_dirs();
218 2         184 my %files;
219 2         16 $self->collect_files($_, \%files) for @dirs;
220              
221 2         12 return join "\n", $shebang, $self->fatpack_code(\%files), $script;
222             }
223              
224             # This method can be overload in sub classes
225             # For example to skip POD
226             sub load_file {
227 6     6 0 8 my ($self, $file) = @_;
228 6         26 my $content = do {
229 6         25 local (@ARGV, $/) = ($file);
230             <>
231 6         216 };
232 6         30 close ARGV;
233 6         447 return $content;
234             }
235              
236             sub collect_dirs {
237 2     2 0 4 my ($self) = @_;
238 2         3609 my $cwd = cwd;
239 2         30 return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
240             }
241              
242             sub collect_files {
243 3     3 0 7 my ($self, $dir, $files) = @_;
244             find(sub {
245 10 100   10   370 return unless -f $_;
246 6 50 33     34 !/\.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 6         20 $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
248             $self->load_file($File::Find::name);
249 3         305 }, $dir);
250             }
251              
252             sub load_main_script {
253 1     1 0 2 my ($self, $file) = @_;
254 1 50       21 open my $fh, "<", $file or die("Can't read $file: $!");
255 1         15 my $shebang = <$fh>;
256 1         8 my $script = join "", <$fh>;
257 1         6 close $fh;
258 1 50       4 unless ( index($shebang, '#!') == 0 ) {
259 1         4 $script = $shebang . $script;
260 1         2 $shebang = "";
261             }
262 1         5 return ($shebang, $script);
263             }
264              
265             sub fatpack_start {
266 2     2 0 9 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'
269             BEGIN {
270             my %fatpacked;
271             END_START
272             }
273              
274             sub fatpack_end {
275 2     2 0 5 return stripspace <<' END_END';
276             s/^ //mg for values %fatpacked;
277              
278             my $class = 'FatPacked::'.(0+\%fatpacked);
279             no strict 'refs';
280             *{"${class}::files"} = sub { keys %{$_[0]} };
281              
282             if ($] < 5.008) {
283             *{"${class}::INC"} = sub {
284             if (my $fat = $_[0]{$_[1]}) {
285             my $pos = 0;
286             my $last = length $fat;
287             return (sub {
288             return 0 if $pos == $last;
289             my $next = (1 + index $fat, "\n", $pos) || $last;
290             $_ .= substr $fat, $pos, $next - $pos;
291             $pos = $next;
292             return 1;
293             });
294             }
295             };
296             }
297              
298             else {
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?)";
303             return $fh;
304             }
305             return;
306             };
307             }
308              
309             unshift @INC, bless \%fatpacked, $class;
310             } # END OF FATPACK CODE
311             END_END
312             }
313              
314             sub fatpack_code {
315 2     2 0 2 my ($self, $files) = @_;
316             my @segments = map {
317 2         14 (my $stub = $_) =~ s/\.pm$//;
  6         17  
318 6         13 my $name = uc join '_', split '/', $stub;
319 6         8 my $data = $files->{$_}; $data =~ s/^/ /mg; $data =~ s/(?
  6         26  
  6         10  
320 6         32 '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
321             .qq!${data}${name}\n!;
322             } sort keys %$files;
323              
324 2         7 return join "\n", $self->fatpack_start, @segments, $self->fatpack_end;
325             }
326              
327             =encoding UTF-8
328              
329             =head1 NAME
330              
331             App::FatPacker - pack your dependencies onto your script file
332              
333             =head1 SYNOPSIS
334              
335             $ fatpack pack myscript.pl >myscript.packed.pl
336              
337             Or, with more step-by-step control:
338              
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
343              
344             See the documentation for the L script itself for more information.
345              
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.
348              
349             =head1 SEE ALSO
350              
351             L
352              
353             =head1 SUPPORT
354              
355             Bugs may be submitted through L
356             (or L).
357              
358             You can normally also obtain assistance on irc, in #toolchain on irc.perl.org.
359              
360             =head1 AUTHOR
361              
362             Matt S. Trout (mst)
363              
364             =head2 CONTRIBUTORS
365              
366             miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA)
367              
368             tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM)
369              
370             dg - David Leadbeater (cpan:DGL)
371              
372             gugod - 劉康民 (cpan:GUGOD)
373              
374             t0m - Tomas Doran (cpan:BOBTFISH)
375              
376             sawyer - Sawyer X (cpan:XSAWYERX)
377              
378             ether - Karen Etheridge (cpan:ETHER)
379              
380             Mithaldu - Christian Walde (cpan:MITHALDU)
381              
382             dolmen - Olivier Mengué (cpan:DOLMEN)
383              
384             djerius - Diab Jerius (cpan:DJERIUS)
385              
386             haarg - Graham Knop (cpan:HAARG>
387              
388             Many more people are probably owed thanks for ideas. Yet
389             another doc nit to fix.
390              
391             =head1 COPYRIGHT
392              
393             Copyright (c) 2010 the App::FatPacker L and L
394             as listed above.
395              
396             =head1 LICENSE
397              
398             This library is free software and may be distributed under the same terms
399             as perl itself.
400              
401             =cut
402              
403             1;
404