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.009014'; # 0.009.014
  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_trace {
  71   my ($self, $args) = @_;
  72
  73   $args = $self->call_parser($args => [
  74     'to=s' => \my $file,
  75     'to-stderr' => \my $to_stderr,
  76     'use=s' => \my @additional_use
  77   ]);
  78
  79   die "Can't use to and to-stderr on same call" if $file && $to_stderr;
  80
  81   $file ||= 'fatpacker.trace';
  82
  83   if (!$to_stderr and -e $file) {
  84     unlink $file or die "Couldn't remove old trace file: $!";
  85   }
  86   my $arg = do {
  87     if ($to_stderr) {
  88       ">&STDERR"
  89     } elsif ($file) {
  90       ">>${file}"
  91     }
  92   };
  93
  94   $self->trace(
  95     use => \@additional_use,
  96     args => $args,
  97     output => $arg,
  98   );
  99 }
 100
 101 sub trace {
 102   my ($self, %opts) = @_;
 103
 104   my $output = $opts{output};
 105   my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]};
 106
 107   local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$trace_opts;
 108
 109   my @args = @{$opts{args}||[]};
 110
 111   if ($output) {
 112     # user specified output target, JFDI
 113     system $^X, @args;
 114     return;
 115   } else {
 116     # no output target specified, slurp
 117     open my $out_fh, '-|', $^X, @args;
 118     return do { local $/; <$out_fh> };
 119   }
 120 }
 121
 122 sub script_command_packlists_for {
 123   my ($self, $args) = @_;
 124   foreach my $pl ($self->packlists_containing($args)) {
 125     print "${pl}\n";
 126   }
 127 }
 128
 129 sub packlists_containing {
 130   my ($self, $targets) = @_;
 131   my @targets = @$targets;
 132   foreach my $t (@targets) {
 133     require $t;
 134   }
 135   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 136   my %pack_rev;
 137   my $cwd = cwd;
 138   find(sub {
 139     return unless $_ eq '.packlist' && -f $_;
 140     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 141   }, @search);
 142   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
 143   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
 144   sort keys %found;
 145 }
 146
 147 sub script_command_tree {
 148   my ($self, $args) = @_;
 149   my $base = catdir(cwd,'fatlib');
 150   $self->packlists_to_tree($base, $args);
 151 }
 152
 153 sub packlists_to_tree {
 154   my ($self, $where, $packlists) = @_;
 155   rmtree $where;
 156   mkpath $where;
 157   foreach my $pl (@$packlists) {
 158     my ($vol, $dirs, $file) = splitpath $pl;
 159     my @dir_parts = splitdir $dirs;
 160     my $pack_base;
 161     PART: foreach my $p (0 .. $#dir_parts) {
 162       if ($dir_parts[$p] eq 'auto') {
 163         # $p-2 since it's <wanted path>/$Config{archname}/auto
 164         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
 165         last PART;
 166       }
 167     }
 168     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 169     foreach my $source (lines_of $pl) {
 170       # there is presumably a better way to do "is this under this base?"
 171       # but if so, it's not obvious to me in File::Spec
 172       next unless substr($source,0,length $pack_base) eq $pack_base;
 173       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 174       my $target_dir = catpath((splitpath $target)[0,1]);
 175       mkpath $target_dir;
 176       copy $source => $target;
 177     }
 178   }
 179 }
 180
 181 sub script_command_file {
 182   my ($self, $args) = @_;
 183   my $file = shift @$args;
 184   my $cwd = cwd;
 185   my @dirs = grep -d, map rel2abs($_, $cwd), ('lib','fatlib');
 186   my %files;
 187   foreach my $dir (@dirs) {
 188     find(sub {
 189       return unless -f $_;
 190       !/\.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;
 191       $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do {
 192         local (@ARGV, $/) = ($File::Find::name); <>
 193       };
 194       close ARGV;
 195     }, $dir);
 196   }
 197   my $start = stripspace <<'  END_START';
 198     # This chunk of stuff was generated by App::FatPacker. To find the original
 199     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 200     BEGIN {
 201     my %fatpacked;
 202   END_START
 203   my $end = stripspace <<'  END_END';
 204     s/^  //mg for values %fatpacked;
 205
 206     unshift @INC, sub {
 207       if (my $fat = $fatpacked{$_[1]}) {
 208         if ($] < 5.008) {
 209           return sub {
 210             return 0 unless length $fat;
 211             $fat =~ s/^([^\n]*\n?)//;
 212             $_ = $1;
 213             return 1;
 214           };
 215         }
 216         open my $fh, '<', \$fat
 217           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 218         return $fh;
 219       }
 220       return
 221     };
 222
 223     } # END OF FATPACK CODE
 224   END_END
 225   my @segments = map {
 226     (my $stub = $_) =~ s/\.pm$//;
 227     my $name = uc join '_', split '/', $stub;
 228     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 229     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
 230     .qq!${data}${name}\n!;
 231   } sort keys %files;
 232   print join "\n", $start, @segments, $end;
 233 }
 234
 235 =encoding UTF-8
 236
 237 =head1 NAME
 238
 239 App::FatPacker - pack your dependencies onto your script file
 240
 241 =head1 SYNOPSIS
 242
 243   $ fatpack trace myscript.pl
 244   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 245   $ fatpack tree `cat packlists`
 246   $ (head -n1 myscript.pl |grep '^#!'; fatpack file; cat myscript.pl) >myscript.packed.pl
 247
 248 The C<head -n1 myscript.pl |grep '^#!'> code pulls out the Unix shebang
 249 line, if there is one, and injects it at the start of the packed script.
 250
 251 See the documentation for the L<fatpack> script itself for more information.
 252
 253 The programmatic API for this code is not yet fully decided, hence the 0.9
 254 release version. Expect that to be cleaned up for 1.0.
 255
 256 =head1 SEE ALSO
 257
 258 L<article for Perl Advent 2012|http://www.perladvent.org/2012/2012-12-14.html>
 259
 260 =head1 SUPPORT
 261
 262 Your current best avenue is to come annoy annoy mst on #toolchain on
 263 irc.perl.org. There should be a non-IRC means of support by 1.0.
 264
 265 =head1 AUTHOR
 266
 267 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 268
 269 =head2 CONTRIBUTORS
 270
 271 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
 272
 273 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
 274
 275 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
 276
 277 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
 278
 279 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
 280
 281 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
 282
 283 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 284
 285 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
 286
 287 Many more people are probably owed thanks for ideas. Yet
 288 another doc nit to fix.
 289
 290 =head1 COPYRIGHT
 291
 292 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 293 as listed above.
 294
 295 =head1 LICENSE
 296
 297 This library is free software and may be distributed under the same terms
 298 as perl itself.
 299
 300 =cut
 301
 302 1;
 303