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