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   {
  97     local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace'.$arg;
  98     system $^X, @$args;
  99   }
 100 }
 101
 102 sub script_command_packlists_for {
 103   my ($self, $args) = @_;
 104   foreach my $pl ($self->packlists_containing($args)) {
 105     print "${pl}\n";
 106   }
 107 }
 108
 109 sub packlists_containing {
 110   my ($self, $targets) = @_;
 111   my @targets = @$targets;
 112   require $_ for @targets;
 113   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 114   my %pack_rev;
 115   my $cwd = cwd;
 116   find(sub {
 117     return unless $_ eq '.packlist' && -f $_;
 118     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 119   }, @search);
 120   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
 121   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
 122   sort keys %found;
 123 }
 124
 125 sub script_command_tree {
 126   my ($self, $args) = @_;
 127   my $base = catdir(cwd,'fatlib');
 128   $self->packlists_to_tree($base, $args);
 129 }
 130
 131 sub packlists_to_tree {
 132   my ($self, $where, $packlists) = @_;
 133   rmtree $where;
 134   mkpath $where;
 135   foreach my $pl (@$packlists) {
 136     my ($vol, $dirs, $file) = splitpath $pl;
 137     my @dir_parts = splitdir $dirs;
 138     my $pack_base;
 139     PART: foreach my $p (0 .. $#dir_parts) {
 140       if ($dir_parts[$p] eq 'auto') {
 141         # $p-2 since it's <wanted path>/$Config{archname}/auto
 142         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
 143         last PART;
 144       }
 145     }
 146     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 147     foreach my $source (lines_of $pl) {
 148       # there is presumably a better way to do "is this under this base?"
 149       # but if so, it's not obvious to me in File::Spec
 150       next unless substr($source,0,length $pack_base) eq $pack_base;
 151       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 152       my $target_dir = catpath((splitpath $target)[0,1]);
 153       mkpath $target_dir;
 154       copy $source => $target;
 155     }
 156   }
 157 }
 158
 159 sub script_command_file {
 160   my ($self, $args) = @_;
 161   my $file = shift @$args;
 162   my $cwd = cwd;
 163   my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
 164   my %files;
 165   foreach my $dir (@dirs) {
 166     find(sub {
 167       return unless -f $_;
 168       !/\.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;
 169       $files{abs2rel($File::Find::name,$dir)} = do {
 170         local (@ARGV, $/) = ($File::Find::name); <>
 171       };
 172     }, $dir);
 173   }
 174   my $start = stripspace <<'  END_START';
 175     # This chunk of stuff was generated by App::FatPacker. To find the original
 176     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 177     BEGIN {
 178     my %fatpacked;
 179   END_START
 180   my $end = stripspace <<'  END_END';
 181     s/^  //mg for values %fatpacked;
 182
 183     unshift @INC, sub {
 184       if (my $fat = $fatpacked{$_[1]}) {
 185         open my $fh, '<', \$fat
 186           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 187         return $fh;
 188       }
 189       return
 190     };
 191
 192     } # END OF FATPACK CODE
 193   END_END
 194   my @segments = map {
 195     (my $stub = $_) =~ s/\.pm$//;
 196     my $name = uc join '_', split '/', $stub;
 197     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 198     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
 199     .qq!${data}${name}\n!;
 200   } sort keys %files;
 201   print join "\n", $start, @segments, $end;
 202 }
 203
 204 =head1 NAME
 205
 206 App::FatPacker - pack your dependencies onto your script file
 207
 208 =head1 SYNOPSIS
 209
 210   $ fatpack trace myscript.pl
 211   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 212   $ fatpack tree `cat packlists`
 213   $ (fatpack file; cat myscript.pl) >myscript.packed.pl
 214
 215 See the documentation for the L<fatpack> script itself for more information.
 216
 217 The programmatic API for this code is not yet fully decided, hence the 0.9
 218 release version. Expect that to be cleaned up for 1.0.
 219
 220 =head1 SUPPORT
 221
 222 Your current best avenue is to come annoy annoy mst on #toolchain on
 223 irc.perl.org. There should be a non-IRC means of support by 1.0.
 224
 225 =head1 AUTHOR
 226
 227 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 228
 229 =head2 CONTRIBUTORS
 230
 231 None as yet, though I probably owe lots of people thanks for ideas. Yet
 232 another doc nit to fix.
 233
 234 =head1 COPYRIGHT
 235
 236 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 237 as listed above.
 238
 239 =head1 LICENSE
 240
 241 This library is free software and may be distributed under the same terms
 242 as perl itself.
 243
 244 =cut
 245
 246 1;
 247