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