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.009018'; # 0.009.017
  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   my $cwd = cwd;
 204   my @dirs = grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
 205   my %files;
 206   foreach my $dir (@dirs) {
 207     find(sub {
 208       return unless -f $_;
 209       !/\.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;
 210       $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do {
 211         local (@ARGV, $/) = ($File::Find::name); <>
 212       };
 213       close ARGV;
 214     }, $dir);
 215   }
 216   my $start = stripspace <<'  END_START';
 217     # This chunk of stuff was generated by App::FatPacker. To find the original
 218     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 219     BEGIN {
 220     my %fatpacked;
 221   END_START
 222   my $end = stripspace <<'  END_END';
 223     s/^  //mg for values %fatpacked;
 224
 225     unshift @INC, sub {
 226       if (my $fat = $fatpacked{$_[1]}) {
 227         if ($] < 5.008) {
 228           return sub {
 229             return 0 unless length $fat;
 230             $fat =~ s/^([^\n]*\n?)//;
 231             $_ = $1;
 232             return 1;
 233           };
 234         }
 235         open my $fh, '<', \$fat
 236           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 237         return $fh;
 238       }
 239       return
 240     };
 241
 242     } # END OF FATPACK CODE
 243   END_END
 244   my @segments = map {
 245     (my $stub = $_) =~ s/\.pm$//;
 246     my $name = uc join '_', split '/', $stub;
 247     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 248     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
 249     .qq!${data}${name}\n!;
 250   } sort keys %files;
 251   my $shebang = "";
 252   my $script = "";
 253   if ( defined $file and -r $file ) {
 254     open my $fh, "<", $file or die("Can't read $file: $!");
 255     $shebang = <$fh>;
 256     $script = join "", <$fh>;
 257     close $fh;
 258     unless ( index($shebang, '#!') == 0 ) {
 259       $script = $shebang . $script;
 260       $shebang = "";
 261     }
 262   }
 263   return join "\n", $shebang, $start, @segments, $end, $script;
 264 }
 265
 266 =encoding UTF-8
 267
 268 =head1 NAME
 269
 270 App::FatPacker - pack your dependencies onto your script file
 271
 272 =head1 SYNOPSIS
 273
 274   $ fatpack pack myscript.pl >myscript.packed.pl
 275
 276 Or, with more step-by-step control:
 277
 278   $ fatpack trace myscript.pl
 279   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 280   $ fatpack tree `cat packlists`
 281   $ fatpack file myscript.pl >myscript.packed.pl
 282
 283 See the documentation for the L<fatpack> script itself for more information.
 284
 285 The programmatic API for this code is not yet fully decided, hence the 0.9
 286 release version. Expect that to be cleaned up for 1.0.
 287
 288 =head1 SEE ALSO
 289
 290 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
 291
 292 =head1 SUPPORT
 293
 294 Your current best avenue is to come annoy annoy mst on #toolchain on
 295 irc.perl.org. There should be a non-IRC means of support by 1.0.
 296
 297 =head1 AUTHOR
 298
 299 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 300
 301 =head2 CONTRIBUTORS
 302
 303 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
 304
 305 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
 306
 307 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
 308
 309 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
 310
 311 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
 312
 313 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
 314
 315 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 316
 317 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
 318
 319 Many more people are probably owed thanks for ideas. Yet
 320 another doc nit to fix.
 321
 322 =head1 COPYRIGHT
 323
 324 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 325 as listed above.
 326
 327 =head1 LICENSE
 328
 329 This library is free software and may be distributed under the same terms
 330 as perl itself.
 331
 332 =cut
 333
 334 1;
 335