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