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