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 Capture::Tiny ();
   8 use Cwd qw(cwd);
   9 use File::Find qw(find);
  10 use File::Spec::Functions qw(
  11   catdir splitpath splitdir catpath rel2abs abs2rel
  12 );
  13 use File::Copy qw(copy);
  14 use File::Path qw(mkpath rmtree);
  15 use B qw(perlstring);
  16
  17 our $VERSION = '0.009006'; # 0.9.6
  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   if (!$to_stderr and -e $file) {
  83     unlink $file or die "Couldn't remove old trace file: $!";
  84   }
  85   my $arg = do {
  86     if ($to_stderr) {
  87       "=&STDERR"
  88     } elsif ($file) {
  89       ">>${file}"
  90     }
  91   };
  92
  93   $self->trace(
  94     use    => \@additional_use,
  95     args   => $args,
  96     output => $arg,
  97   );
  98 }
  99
 100 sub trace {
 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'};
 105   my $capture;
 106
 107   # if the user doesn't provide output, they want to actually
 108   # capture the output and receive it back
 109   if (!$output) {
 110     # throw to STDOUT to differ from STDERR
 111     $output .= '>&STDOUT';
 112
 113     # raise capture flag
 114     $capture++;
 115   }
 116
 117   if(@$use) {
 118     $output .= "," . join ",", @$use;
 119   }
 120
 121   my $trace_sub = sub {
 122      local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$output;
 123      system $^X, @$args;
 124   };
 125
 126   if ($capture) {
 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->()};
 131     return $stdout;
 132   } else {
 133     $trace_sub->();
 134    }
 135 }
 136
 137 sub script_command_packlists_for {
 138   my ($self, $args) = @_;
 139   foreach my $pl ($self->packlists_containing($args)) {
 140     print "${pl}\n";
 141   }
 142 }
 143
 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;
 149   my %pack_rev;
 150   my $cwd = cwd;
 151   find(sub {
 152     return unless $_ eq '.packlist' && -f $_;
 153     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 154   }, @search);
 155   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
 156   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
 157   sort keys %found;
 158 }
 159
 160 sub script_command_tree {
 161   my ($self, $args) = @_;
 162   my $base = catdir(cwd,'fatlib');
 163   $self->packlists_to_tree($base, $args);
 164 }
 165
 166 sub packlists_to_tree {
 167   my ($self, $where, $packlists) = @_;
 168   rmtree $where;
 169   mkpath $where;
 170   foreach my $pl (@$packlists) {
 171     my ($vol, $dirs, $file) = splitpath $pl;
 172     my @dir_parts = splitdir $dirs;
 173     my $pack_base;
 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];
 178         last PART;
 179       }
 180     }
 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]);
 188       mkpath $target_dir;
 189       copy $source => $target;
 190     }
 191   }
 192 }
 193
 194 sub script_command_file {
 195   my ($self, $args) = @_;
 196   my $file = shift @$args;
 197   my $cwd = cwd;
 198   my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
 199   my %files;
 200   foreach my $dir (@dirs) {
 201     find(sub {
 202       return unless -f $_;
 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); <>
 206       };
 207     }, $dir);
 208   }
 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'
 212     BEGIN {
 213     my %fatpacked;
 214   END_START
 215   my $end = stripspace <<'  END_END';
 216     s/^  //mg for values %fatpacked;
 217
 218     unshift @INC, sub {
 219       if (my $fat = $fatpacked{$_[1]}) {
 220         open my $fh, '<', \$fat
 221           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 222         return $fh;
 223       }
 224       return
 225     };
 226
 227     } # END OF FATPACK CODE
 228   END_END
 229   my @segments = map {
 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!;
 235   } sort keys %files;
 236   print join "\n", $start, @segments, $end;
 237 }
 238
 239 =head1 NAME
 240
 241 App::FatPacker - pack your dependencies onto your script file
 242
 243 =head1 SYNOPSIS
 244
 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
 249
 250 See the documentation for the L<fatpack> script itself for more information.
 251
 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.
 254
 255 =head1 SUPPORT
 256
 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.
 259
 260 =head1 AUTHOR
 261
 262 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 263
 264 =head2 CONTRIBUTORS
 265
 266 None as yet, though I probably owe lots of people thanks for ideas. Yet
 267 another doc nit to fix.
 268
 269 =head1 COPYRIGHT
 270
 271 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 272 as listed above.
 273
 274 =head1 LICENSE
 275
 276 This library is free software and may be distributed under the same terms
 277 as perl itself.
 278
 279 =cut
 280
 281 1;
 282