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