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 trace myscript.pl
 274   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 275   $ fatpack tree `cat packlists`
 276   $ (head -n1 myscript.pl |grep '^#!'; fatpack file; cat myscript.pl) >myscript.packed.pl
 277
 278 The C<head -n1 myscript.pl |grep '^#!'> code pulls out the Unix shebang
 279 line, if there is one, and injects it at the start of the packed script.
 280
 281 See the documentation for the L<fatpack> script itself for more information.
 282
 283 The programmatic API for this code is not yet fully decided, hence the 0.9
 284 release version. Expect that to be cleaned up for 1.0.
 285
 286 =head1 SEE ALSO
 287
 288 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
 289
 290 =head1 SUPPORT
 291
 292 Your current best avenue is to come annoy annoy mst on #toolchain on
 293 irc.perl.org. There should be a non-IRC means of support by 1.0.
 294
 295 =head1 AUTHOR
 296
 297 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 298
 299 =head2 CONTRIBUTORS
 300
 301 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
 302
 303 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
 304
 305 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
 306
 307 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
 308
 309 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
 310
 311 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
 312
 313 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 314
 315 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
 316
 317 Many more people are probably owed thanks for ideas. Yet
 318 another doc nit to fix.
 319
 320 =head1 COPYRIGHT
 321
 322 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 323 as listed above.
 324
 325 =head1 LICENSE
 326
 327 This library is free software and may be distributed under the same terms
 328 as perl itself.
 329
 330 =cut
 331
 332 1;
 333