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