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