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