1 package App::FatPacker;
4 use warnings FATAL => 'all';
9 use File::Find qw(find);
10 use File::Spec::Functions qw(
11 catdir splitpath splitdir catpath rel2abs abs2rel
13 use File::Copy qw(copy);
14 use File::Path qw(mkpath rmtree);
17 our $VERSION = '0.009006'; # 0.9.6
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_trace {
71 my ($self, $args) = @_;
73 $args = $self->call_parser( $args => [
75 'to-stderr' => \my $to_stderr,
76 'use=s' => \my @additional_use
79 die "Can't use to and to-stderr on same call" if $file && $to_stderr;
81 $file ||= 'fatpacker.trace';
82 if (!$to_stderr and -e $file) {
83 unlink $file or die "Couldn't remove old trace file: $!";
94 use => \@additional_use,
101 my ($self, %opts) = @_;
102 my $use = defined $opts{'use'} ? $opts{'use'} : [];
103 my $args = defined $opts{'args'} ? $opts{'args'} : [];
104 my $output = $opts{'output'};
107 # if the user doesn't provide output, they want to actually
108 # capture the output and receive it back
110 # throw to STDOUT to differ from STDERR
111 $output .= '>&STDOUT';
118 $output .= "," . join ",", @$use;
121 my $trace_sub = sub {
122 local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$output;
127 # capture both STDOUT and STDERR so we could throw away STDERR
128 # STDOUT will contain the trace
129 # STDERR will contain the "syntax OK" statement
130 my ($stdout, $stderr) = Capture::Tiny::capture {$trace_sub->()};
137 sub script_command_packlists_for {
138 my ($self, $args) = @_;
139 foreach my $pl ($self->packlists_containing($args)) {
144 sub packlists_containing {
145 my ($self, $targets) = @_;
146 my @targets = @$targets;
147 require $_ for @targets;
148 my @search = grep -d $_, map catdir($_, 'auto'), @INC;
152 return unless $_ eq '.packlist' && -f $_;
153 $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
155 chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
156 my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
160 sub script_command_tree {
161 my ($self, $args) = @_;
162 my $base = catdir(cwd,'fatlib');
163 $self->packlists_to_tree($base, $args);
166 sub packlists_to_tree {
167 my ($self, $where, $packlists) = @_;
170 foreach my $pl (@$packlists) {
171 my ($vol, $dirs, $file) = splitpath $pl;
172 my @dir_parts = splitdir $dirs;
174 PART: foreach my $p (0 .. $#dir_parts) {
175 if ($dir_parts[$p] eq 'auto') {
176 # $p-2 since it's <wanted path>/$Config{archname}/auto
177 $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
181 die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
182 foreach my $source (lines_of $pl) {
183 # there is presumably a better way to do "is this under this base?"
184 # but if so, it's not obvious to me in File::Spec
185 next unless substr($source,0,length $pack_base) eq $pack_base;
186 my $target = rel2abs( abs2rel($source, $pack_base), $where );
187 my $target_dir = catpath((splitpath $target)[0,1]);
189 copy $source => $target;
194 sub script_command_file {
195 my ($self, $args) = @_;
196 my $file = shift @$args;
198 my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
200 foreach my $dir (@dirs) {
203 !/\.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;
204 $files{abs2rel($File::Find::name,$dir)} = do {
205 local (@ARGV, $/) = ($File::Find::name); <>
209 my $start = stripspace <<' END_START';
210 # This chunk of stuff was generated by App::FatPacker. To find the original
211 # file's code, look for the end of this BEGIN block or the string 'FATPACK'
215 my $end = stripspace <<' END_END';
216 s/^ //mg for values %fatpacked;
219 if (my $fat = $fatpacked{$_[1]}) {
220 open my $fh, '<', \$fat
221 or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
227 } # END OF FATPACK CODE
230 (my $stub = $_) =~ s/\.pm$//;
231 my $name = uc join '_', split '/', $stub;
232 my $data = $files{$_}; $data =~ s/^/ /mg; $data =~ s/(?<!\n)\z/\n/;
233 '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
234 .qq!${data}${name}\n!;
236 print join "\n", $start, @segments, $end;
241 App::FatPacker - pack your dependencies onto your script file
245 $ fatpack trace myscript.pl
246 $ fatpack packlists-for `cat fatpacker.trace` >packlists
247 $ fatpack tree `cat packlists`
248 $ (fatpack file; cat myscript.pl) >myscript.packed.pl
250 See the documentation for the L<fatpack> script itself for more information.
252 The programmatic API for this code is not yet fully decided, hence the 0.9
253 release version. Expect that to be cleaned up for 1.0.
257 Your current best avenue is to come annoy annoy mst on #toolchain on
258 irc.perl.org. There should be a non-IRC means of support by 1.0.
262 Matt S. Trout (mst) <mst@shadowcat.co.uk>
266 None as yet, though I probably owe lots of people thanks for ideas. Yet
267 another doc nit to fix.
271 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
276 This library is free software and may be distributed under the same terms