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.010008'; # v0.10.8
  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 STDERR "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;
 146   {
 147     local @INC = ('lib', @INC);
 148     foreach my $t (@$targets) {
 149       unless (eval { require $t; 1}) {
 150         warn "Failed to load ${t}: $@\n"
 151             ."Make sure you're not missing a packlist as a result\n";
 152         next;
 153       }
 154       push @targets, $t;
 155     }
 156   }
 157   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 158   my %pack_rev;
 159   find({
 160     no_chdir => 1,
 161     wanted => sub {
 162       return unless /[\\\/]\.packlist$/ && -f $_;
 163       $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 164     },
 165   }, @search);
 166   my %found; @found{map +($pack_rev{Cwd::abs_path($INC{$_})}||()), @targets} = ();
 167   sort keys %found;
 168 }
 169
 170 sub script_command_tree {
 171   my ($self, $args) = @_;
 172   my $base = catdir(cwd,'fatlib');
 173   $self->packlists_to_tree($base, $args);
 174 }
 175
 176 sub packlists_to_tree {
 177   my ($self, $where, $packlists) = @_;
 178   rmtree $where;
 179   mkpath $where;
 180   foreach my $pl (@$packlists) {
 181     my ($vol, $dirs, $file) = splitpath $pl;
 182     my @dir_parts = splitdir $dirs;
 183     my $pack_base;
 184     PART: foreach my $p (0 .. $#dir_parts) {
 185       if ($dir_parts[$p] eq 'auto') {
 186         # $p-2 normally since it's <wanted path>/$Config{archname}/auto but
 187         # if the last bit is a number it's $Config{archname}/$version/auto
 188         # so use $p-3 in that case
 189         my $version_lib = 0+!!($dir_parts[$p-1] =~ /^[0-9.]+$/);
 190         $pack_base = catpath $vol, catdir @dir_parts[0..$p-(2+$version_lib)];
 191         last PART;
 192       }
 193     }
 194     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 195     foreach my $source (lines_of $pl) {
 196       # there is presumably a better way to do "is this under this base?"
 197       # but if so, it's not obvious to me in File::Spec
 198       next unless substr($source,0,length $pack_base) eq $pack_base;
 199       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 200       my $target_dir = catpath((splitpath $target)[0,1]);
 201       mkpath $target_dir;
 202       copy $source => $target;
 203     }
 204   }
 205 }
 206
 207 sub script_command_file {
 208   my ($self, $args) = @_;
 209   my $file = shift @$args;
 210   print $self->fatpack_file($file);
 211 }
 212
 213 sub fatpack_file {
 214   my ($self, $file) = @_;
 215
 216   my $shebang = "";
 217   my $script = "";
 218   if ( defined $file and -r $file ) {
 219     ($shebang, $script) = $self->load_main_script($file);
 220   }
 221
 222   my @dirs = $self->collect_dirs();
 223   my %files;
 224   $self->collect_files($_, \%files) for @dirs;
 225
 226   return join "\n", $shebang, $self->fatpack_code(\%files), $script;
 227 }
 228
 229 # This method can be overload in sub classes
 230 # For example to skip POD
 231 sub load_file {
 232   my ($self, $file) = @_;
 233   my $content = do {
 234     local (@ARGV, $/) = ($file);
 235     <>
 236   };
 237   close ARGV;
 238   return $content;
 239 }
 240
 241 sub collect_dirs {
 242   my ($self) = @_;
 243   my $cwd = cwd;
 244   return grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
 245 }
 246
 247 sub collect_files {
 248   my ($self, $dir, $files) = @_;
 249   find(sub {
 250     return unless -f $_;
 251     !/\.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;
 252     $files->{File::Spec::Unix->abs2rel($File::Find::name,$dir)} =
 253       $self->load_file($File::Find::name);
 254   }, $dir);
 255 }
 256
 257 sub load_main_script {
 258   my ($self, $file) = @_;
 259   open my $fh, "<", $file or die("Can't read $file: $!");
 260   my $shebang = <$fh>;
 261   my $script = join "", <$fh>;
 262   close $fh;
 263   unless ( index($shebang, '#!') == 0 ) {
 264     $script = $shebang . $script;
 265     $shebang = "";
 266   }
 267   return ($shebang, $script);
 268 }
 269
 270 sub fatpack_start {
 271   return stripspace <<'  END_START';
 272     # This chunk of stuff was generated by App::FatPacker. To find the original
 273     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 274     BEGIN {
 275     my %fatpacked;
 276   END_START
 277 }
 278
 279 sub fatpack_end {
 280   return stripspace <<'  END_END';
 281     s/^  //mg for values %fatpacked;
 282
 283     my $class = 'FatPacked::'.(0+\%fatpacked);
 284     no strict 'refs';
 285     *{"${class}::files"} = sub { keys %{$_[0]} };
 286
 287     if ($] < 5.008) {
 288       *{"${class}::INC"} = sub {
 289         if (my $fat = $_[0]{$_[1]}) {
 290           my $pos = 0;
 291           my $last = length $fat;
 292           return (sub {
 293             return 0 if $pos == $last;
 294             my $next = (1 + index $fat, "\n", $pos) || $last;
 295             $_ .= substr $fat, $pos, $next - $pos;
 296             $pos = $next;
 297             return 1;
 298           });
 299         }
 300       };
 301     }
 302
 303     else {
 304       *{"${class}::INC"} = sub {
 305         if (my $fat = $_[0]{$_[1]}) {
 306           open my $fh, '<', \$fat
 307             or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 308           return $fh;
 309         }
 310         return;
 311       };
 312     }
 313
 314     unshift @INC, bless \%fatpacked, $class;
 315   } # END OF FATPACK CODE
 316   END_END
 317 }
 318
 319 sub fatpack_code {
 320   my ($self, $files) = @_;
 321   my @segments = map {
 322     (my $stub = $_) =~ s/\.pm$//;
 323     my $name = uc join '_', split '/', $stub;
 324     my $data = $files->{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 325     '$fatpacked{'.perlstring($_).qq!} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'${name}';\n!
 326     .qq!${data}${name}\n!;
 327   } sort keys %$files;
 328
 329   return join "\n", $self->fatpack_start, @segments, $self->fatpack_end;
 330 }
 331
 332 =encoding UTF-8
 333
 334 =head1 NAME
 335
 336 App::FatPacker - pack your dependencies onto your script file
 337
 338 =head1 SYNOPSIS
 339
 340   $ fatpack pack myscript.pl >myscript.packed.pl
 341
 342 Or, with more step-by-step control:
 343
 344   $ fatpack trace myscript.pl
 345   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 346   $ fatpack tree `cat packlists`
 347   $ fatpack file myscript.pl >myscript.packed.pl
 348
 349 Each command is designed to be simple and self-contained so that you can modify
 350 the input/output of each step as needed. See the documentation for the
 351 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 CAVEATS
 357
 358 As dependency module code is copied into the resulting file as text, only
 359 pure-perl dependencies can be packed, not compiled XS code.
 360
 361 The currently-installed dependencies to pack are found via F<.packlist> files,
 362 which are generally only included in non-core distributions that were installed
 363 by a CPAN installer. This is a feature; see L<fatpack/packlists-for> for
 364 details. (a notable exception to this is FreeBSD, which, since its packaging
 365 system is designed to work equivalently to a source install, does preserve
 366 the packlist files)
 367
 368 =head1 SEE ALSO
 369
 370 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
 371
 372 L<pp> - PAR Packager, a much more complex architecture-dependent packer that
 373 can pack compiled code and even a Perl interpreter
 374
 375 =head1 SUPPORT
 376
 377 Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=App-FatPacker>
 378 (or L<bug-App-FatPacker@rt.cpan.org|mailto:bug-App-FatPacker@rt.cpan.org>).
 379
 380 You can normally also obtain assistance on irc, in #toolchain on irc.perl.org.
 381
 382 =head1 AUTHOR
 383
 384 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 385
 386 =head2 CONTRIBUTORS
 387
 388 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
 389
 390 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
 391
 392 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
 393
 394 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
 395
 396 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
 397
 398 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
 399
 400 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 401
 402 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
 403
 404 dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
 405
 406 djerius - Diab Jerius (cpan:DJERIUS) <djerius@cpan.org>
 407
 408 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 409
 410 grinnz - Dan Book (cpan:DBOOK) <dbook@cpan.org>
 411
 412 Many more people are probably owed thanks for ideas. Yet
 413 another doc nit to fix.
 414
 415 =head1 COPYRIGHT
 416
 417 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 418 as listed above.
 419
 420 =head1 LICENSE
 421
 422 This library is free software and may be distributed under the same terms
 423 as perl itself.
 424
 425 =cut
 426
 427 1;
 428