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