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.010000'; # 0.10.0
  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} = join ' ',
 121     ($ENV{PERL5OPT}||()), '-MApp::FatPacker::Trace='.$trace_opts;
 122
 123   my @args = @{$opts{args}||[]};
 124
 125   if ($output) {
 126     # user specified output target, JFDI
 127     system $^X, @args;
 128     return;
 129   } else {
 130     # no output target specified, slurp
 131     open my $out_fh, "$^X @args |";
 132     return do { local $/; <$out_fh> };
 133   }
 134 }
 135
 136 sub script_command_packlists_for {
 137   my ($self, $args) = @_;
 138   foreach my $pl ($self->packlists_containing($args)) {
 139     print "${pl}\n";
 140   }
 141 }
 142
 143 sub packlists_containing {
 144   my ($self, $targets) = @_;
 145   my @targets = @$targets;
 146   foreach my $t (@targets) {
 147     require $t;
 148   }
 149   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 150   my %pack_rev;
 151   find({
 152     no_chdir => 1,
 153     wanted => sub {
 154       return unless /[\\\/]\.packlist$/ && -f $_;
 155       $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 156     },
 157   }, @search);
 158   my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
 159   sort keys %found;
 160 }
 161
 162 sub script_command_tree {
 163   my ($self, $args) = @_;
 164   my $base = catdir(cwd,'fatlib');
 165   $self->packlists_to_tree($base, $args);
 166 }
 167
 168 sub packlists_to_tree {
 169   my ($self, $where, $packlists) = @_;
 170   rmtree $where;
 171   mkpath $where;
 172   foreach my $pl (@$packlists) {
 173     my ($vol, $dirs, $file) = splitpath $pl;
 174     my @dir_parts = splitdir $dirs;
 175     my $pack_base;
 176     PART: foreach my $p (0 .. $#dir_parts) {
 177       if ($dir_parts[$p] eq 'auto') {
 178         # $p-2 since it's <wanted path>/$Config{archname}/auto
 179         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
 180         last PART;
 181       }
 182     }
 183     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 184     foreach my $source (lines_of $pl) {
 185       # there is presumably a better way to do "is this under this base?"
 186       # but if so, it's not obvious to me in File::Spec
 187       next unless substr($source,0,length $pack_base) eq $pack_base;
 188       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 189       my $target_dir = catpath((splitpath $target)[0,1]);
 190       mkpath $target_dir;
 191       copy $source => $target;
 192     }
 193   }
 194 }
 195
 196 sub script_command_file {
 197   my ($self, $args) = @_;
 198   my $file = shift @$args;
 199   print $self->fatpack_file($file);
 200 }
 201
 202 sub fatpack_file {
 203   my ($self, $file) = @_;
 204
 205   my $shebang = "";
 206   my $script = "";
 207   if ( defined $file and -r $file ) {
 208     ($shebang, $script) = $self->load_main_script($file);
 209   }
 210
 211   my @dirs = $self->collect_dirs();
 212   my %files;
 213   $self->collect_files($_, \%files) for @dirs;
 214
 215   return join "\n", $shebang, $self->fatpack_code(\%files), $script;
 216 }
 217
 218 # This method can be overload in sub classes
 219 # For example to skip POD
 220 sub load_file {
 221   my ($self, $file) = @_;
 222   my $content = do {
 223     local (@ARGV, $/) = ($file);
 224     <>
 225   };
 226   close ARGV;
 227   return $content;
 228 }
 229
 230 sub collect_dirs {
 231   my ($self) = @_;
 232   my $cwd = cwd;
 233   return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
 234 }
 235
 236 sub collect_files {
 237   my ($self, $dir, $files) = @_;
 238   find(sub {
 239     return unless -f $_;
 240     !/\.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;
 241     $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
 242       $self->load_file($File::Find::name);
 243   }, $dir);
 244 }
 245
 246 sub load_main_script {
 247   my ($self, $file) = @_;
 248   open my $fh, "<", $file or die("Can't read $file: $!");
 249   my $shebang = <$fh>;
 250   my $script = join "", <$fh>;
 251   close $fh;
 252   unless ( index($shebang, '#!') == 0 ) {
 253     $script = $shebang . $script;
 254     $shebang = "";
 255   }
 256   return ($shebang, $script);
 257 }
 258
 259 sub fatpack_start {
 260   return stripspace <<'  END_START';
 261     # This chunk of stuff was generated by App::FatPacker. To find the original
 262     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 263     BEGIN {
 264     my %fatpacked;
 265   END_START
 266 }
 267
 268 sub fatpack_end {
 269   return stripspace <<'  END_END';
 270     s/^  //mg for values %fatpacked;
 271
 272     my $class = 'FatPacked::'.(0+\%fatpacked);
 273     no strict 'refs';
 274     *{"${class}::files"} = sub { keys %{$_[0]} };
 275
 276     if ($] < 5.008) {
 277       *{"${class}::INC"} = sub {
 278          if (my $fat = $_[0]{$_[1]}) {
 279            return sub {
 280              return 0 unless length $fat;
 281              $fat =~ s/^([^\n]*\n?)//;
 282              $_ = $1;
 283              return 1;
 284            };
 285          }
 286          return;
 287       };
 288     }
 289
 290     else {
 291       *{"${class}::INC"} = sub {
 292         if (my $fat = $_[0]{$_[1]}) {
 293           open my $fh, '<', \$fat
 294             or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 295           return $fh;
 296         }
 297         return;
 298       };
 299     }
 300
 301     unshift @INC, bless \%fatpacked, $class;
 302   } # END OF FATPACK CODE
 303   END_END
 304 }
 305
 306 sub fatpack_code {
 307   my ($self, $files) = @_;
 308   my @segments = map {
 309     (my $stub = $_) =~ s/\.pm$//;
 310     my $name = uc join '_', split '/', $stub;
 311     my $data = $files->{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 312     '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
 313     .qq!${data}${name}\n!;
 314   } sort keys %$files;
 315
 316   return join "\n", $self->fatpack_start, @segments, $self->fatpack_end;
 317 }
 318
 319 =encoding UTF-8
 320
 321 =head1 NAME
 322
 323 App::FatPacker - pack your dependencies onto your script file
 324
 325 =head1 SYNOPSIS
 326
 327   $ fatpack pack myscript.pl >myscript.packed.pl
 328
 329 Or, with more step-by-step control:
 330
 331   $ fatpack trace myscript.pl
 332   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 333   $ fatpack tree `cat packlists`
 334   $ fatpack file myscript.pl >myscript.packed.pl
 335
 336 See the documentation for the L<fatpack> script itself for more information.
 337
 338 The programmatic API for this code is not yet fully decided, hence the 0.x
 339 release version. Expect that to be cleaned up for 1.0.
 340
 341 =head1 SEE ALSO
 342
 343 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
 344
 345 =head1 SUPPORT
 346
 347 Your current best avenue is to come annoy mst on #toolchain on
 348 irc.perl.org. There should be a non-IRC means of support by 1.0.
 349
 350 =head1 AUTHOR
 351
 352 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 353
 354 =head2 CONTRIBUTORS
 355
 356 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
 357
 358 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
 359
 360 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
 361
 362 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
 363
 364 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
 365
 366 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
 367
 368 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 369
 370 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
 371
 372 dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
 373
 374 djerius - Diab Jerius (cpan:DJERIUS) <djerius@cpan.org>
 375
 376 haarg - Graham Knop (cpan:HAARG> <haarg@haarg.org>
 377
 378 Many more people are probably owed thanks for ideas. Yet
 379 another doc nit to fix.
 380
 381 =head1 COPYRIGHT
 382
 383 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 384 as listed above.
 385
 386 =head1 LICENSE
 387
 388 This library is free software and may be distributed under the same terms
 389 as perl itself.
 390
 391 =cut
 392
 393 1;
 394