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