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::Copy qw(copy);
  13 use File::Path qw(mkpath rmtree);
  14 use B qw(perlstring);
  15
  16 our $VERSION = '0.009006'; # 0.9.6
  17
  18 $VERSION = eval $VERSION;
  19
  20 sub call_parser {
  21   my $self = shift;
  22   my ( $args, $options ) = @_;
  23
  24   local *ARGV = [ @{$args} ];
  25   $self->{'option_parser'}->getoptions( @{$options} );
  26
  27   return [ @ARGV ];
  28 }
  29
  30 sub lines_of {
  31   map +(chomp,$_)[1], do { local @ARGV = ($_[0]); <> };
  32 }
  33
  34 sub stripspace {
  35   my ($text) = @_;
  36   $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
  37   $text;
  38 }
  39
  40 sub import {
  41   $_[1] && $_[1] eq '-run_script'
  42     and return shift->new->run_script;
  43 }
  44
  45 sub new {
  46   bless {
  47     option_parser => Getopt::Long::Parser->new(
  48       config => [ qw(require_order pass_through bundling no_auto_abbrev) ]
  49     ),
  50   }, $_[0];
  51 }
  52
  53 sub run_script {
  54   my ($self, $args) = @_;
  55   my @args = $args ? @$args : @ARGV;
  56   (my $cmd = shift @args || 'help') =~ s/-/_/g;
  57
  58   if (my $meth = $self->can("script_command_${cmd}")) {
  59     $self->$meth(\@args);
  60   } else {
  61     die "No such command ${cmd}";
  62   }
  63 }
  64
  65 sub script_command_help {
  66   print "Try `perldoc fatpack` for how to use me\n";
  67 }
  68
  69 sub script_command_trace {
  70   my ($self, $args) = @_;
  71
  72   $args = $self->call_parser( $args => [
  73     'to=s' => \my $file,
  74     'to-stderr' => \my $to_stderr,
  75     'use=s' => \my @additional_use
  76   ] );
  77
  78   die "Can't use to and to-stderr on same call" if $file && $to_stderr;
  79
  80   $file ||= 'fatpacker.trace';
  81   if (!$to_stderr and -e $file) {
  82     unlink $file or die "Couldn't remove old trace file: $!";
  83   }
  84   my $arg = do {
  85     if ($to_stderr) {
  86       "=>&STDERR"
  87     } elsif ($file) {
  88       "=>>${file}"
  89     }
  90   };
  91
  92   if(@additional_use) {
  93     $arg .= "," . join ",", @additional_use;
  94   }
  95
  96   $self->trace(
  97     output => $arg,
  98     args   => $args,
  99   );
 100 }
 101
 102 sub trace {
 103   my ($self, %opts) = @_;
 104   my $output = $opts{'output'};
 105   my $args = $opts{'args'};
 106
 107   {
 108     local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace'.$output;
 109     system $^X, @$args;
 110   }
 111 }
 112
 113 sub script_command_packlists_for {
 114   my ($self, $args) = @_;
 115   foreach my $pl ($self->packlists_containing($args)) {
 116     print "${pl}\n";
 117   }
 118 }
 119
 120 sub packlists_containing {
 121   my ($self, $targets) = @_;
 122   my @targets = @$targets;
 123   require $_ for @targets;
 124   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 125   my %pack_rev;
 126   my $cwd = cwd;
 127   find(sub {
 128     return unless $_ eq '.packlist' && -f $_;
 129     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 130   }, @search);
 131   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
 132   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
 133   sort keys %found;
 134 }
 135
 136 sub script_command_tree {
 137   my ($self, $args) = @_;
 138   my $base = catdir(cwd,'fatlib');
 139   $self->packlists_to_tree($base, $args);
 140 }
 141
 142 sub packlists_to_tree {
 143   my ($self, $where, $packlists) = @_;
 144   rmtree $where;
 145   mkpath $where;
 146   foreach my $pl (@$packlists) {
 147     my ($vol, $dirs, $file) = splitpath $pl;
 148     my @dir_parts = splitdir $dirs;
 149     my $pack_base;
 150     PART: foreach my $p (0 .. $#dir_parts) {
 151       if ($dir_parts[$p] eq 'auto') {
 152         # $p-2 since it's <wanted path>/$Config{archname}/auto
 153         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
 154         last PART;
 155       }
 156     }
 157     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 158     foreach my $source (lines_of $pl) {
 159       # there is presumably a better way to do "is this under this base?"
 160       # but if so, it's not obvious to me in File::Spec
 161       next unless substr($source,0,length $pack_base) eq $pack_base;
 162       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 163       my $target_dir = catpath((splitpath $target)[0,1]);
 164       mkpath $target_dir;
 165       copy $source => $target;
 166     }
 167   }
 168 }
 169
 170 sub script_command_file {
 171   my ($self, $args) = @_;
 172   my $file = shift @$args;
 173   my $cwd = cwd;
 174   my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
 175   my %files;
 176   foreach my $dir (@dirs) {
 177     find(sub {
 178       return unless -f $_;
 179       !/\.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;
 180       $files{abs2rel($File::Find::name,$dir)} = do {
 181         local (@ARGV, $/) = ($File::Find::name); <>
 182       };
 183     }, $dir);
 184   }
 185   my $start = stripspace <<'  END_START';
 186     # This chunk of stuff was generated by App::FatPacker. To find the original
 187     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 188     BEGIN {
 189     my %fatpacked;
 190   END_START
 191   my $end = stripspace <<'  END_END';
 192     s/^  //mg for values %fatpacked;
 193
 194     unshift @INC, sub {
 195       if (my $fat = $fatpacked{$_[1]}) {
 196         open my $fh, '<', \$fat
 197           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 198         return $fh;
 199       }
 200       return
 201     };
 202
 203     } # END OF FATPACK CODE
 204   END_END
 205   my @segments = map {
 206     (my $stub = $_) =~ s/\.pm$//;
 207     my $name = uc join '_', split '/', $stub;
 208     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 209     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
 210     .qq!${data}${name}\n!;
 211   } sort keys %files;
 212   print join "\n", $start, @segments, $end;
 213 }
 214
 215 =head1 NAME
 216
 217 App::FatPacker - pack your dependencies onto your script file
 218
 219 =head1 SYNOPSIS
 220
 221   $ fatpack trace myscript.pl
 222   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 223   $ fatpack tree `cat packlists`
 224   $ (fatpack file; cat myscript.pl) >myscript.packed.pl
 225
 226 See the documentation for the L<fatpack> script itself for more information.
 227
 228 The programmatic API for this code is not yet fully decided, hence the 0.9
 229 release version. Expect that to be cleaned up for 1.0.
 230
 231 =head1 SUPPORT
 232
 233 Your current best avenue is to come annoy annoy mst on #toolchain on
 234 irc.perl.org. There should be a non-IRC means of support by 1.0.
 235
 236 =head1 AUTHOR
 237
 238 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 239
 240 =head2 CONTRIBUTORS
 241
 242 None as yet, though I probably owe lots of people thanks for ideas. Yet
 243 another doc nit to fix.
 244
 245 =head1 COPYRIGHT
 246
 247 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 248 as listed above.
 249
 250 =head1 LICENSE
 251
 252 This library is free software and may be distributed under the same terms
 253 as perl itself.
 254
 255 =cut
 256
 257 1;
 258