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