lib/App/FatPacker.pm

   1 package App::FatPacker;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5 use Getopt::Long;
   6 use Cwd qw(cwd);
   7 use File::Find qw(find);
   8 use File::Spec::Functions qw(
   9   catdir splitpath splitdir catpath rel2abs abs2rel
  10 );
  11 use File::Spec::Unix;
  12 use File::Copy qw(copy);
  13 use File::Path qw(mkpath rmtree);
  14 use B qw(perlstring);
  15
  16 our $VERSION = '0.009011'; # 0.9.11
  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   foreach my $t (@targets) {
 137     require $t;
 138   }
 139   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 140   my %pack_rev;
 141   my $cwd = cwd;
 142   find(sub {
 143     return unless $_ eq '.packlist' && -f $_;
 144     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 145   }, @search);
 146   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
 147   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
 148   sort keys %found;
 149 }
 150
 151 sub script_command_tree {
 152   my ($self, $args) = @_;
 153   my $base = catdir(cwd,'fatlib');
 154   $self->packlists_to_tree($base, $args);
 155 }
 156
 157 sub packlists_to_tree {
 158   my ($self, $where, $packlists) = @_;
 159   rmtree $where;
 160   mkpath $where;
 161   foreach my $pl (@$packlists) {
 162     my ($vol, $dirs, $file) = splitpath $pl;
 163     my @dir_parts = splitdir $dirs;
 164     my $pack_base;
 165     PART: foreach my $p (0 .. $#dir_parts) {
 166       if ($dir_parts[$p] eq 'auto') {
 167         # $p-2 since it's <wanted path>/$Config{archname}/auto
 168         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
 169         last PART;
 170       }
 171     }
 172     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 173     foreach my $source (lines_of $pl) {
 174       # there is presumably a better way to do "is this under this base?"
 175       # but if so, it's not obvious to me in File::Spec
 176       next unless substr($source,0,length $pack_base) eq $pack_base;
 177       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 178       my $target_dir = catpath((splitpath $target)[0,1]);
 179       mkpath $target_dir;
 180       copy $source => $target;
 181     }
 182   }
 183 }
 184
 185 sub script_command_file {
 186   my ($self, $args) = @_;
 187   my $file = shift @$args;
 188   my $cwd = cwd;
 189   my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
 190   my %files;
 191   foreach my $dir (@dirs) {
 192     find(sub {
 193       return unless -f $_;
 194       !/\.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;
 195       $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do {
 196         local (@ARGV, $/) = ($File::Find::name); <>
 197       };
 198       close ARGV;
 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         if ($] < 5.008) {
 213           return sub {
 214             return 0 unless length $fat;
 215             $text =~ s/^([^\n]*\n?)//;
 216             $_ = $1;
 217             return 1;
 218           };
 219         }
 220         open my $fh, '<', \$fat
 221           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 222         return $fh;
 223       }
 224       return
 225     };
 226
 227     } # END OF FATPACK CODE
 228   END_END
 229   my @segments = map {
 230     (my $stub = $_) =~ s/\.pm$//;
 231     my $name = uc join '_', split '/', $stub;
 232     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 233     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
 234     .qq!${data}${name}\n!;
 235   } sort keys %files;
 236   print join "\n", $start, @segments, $end;
 237 }
 238
 239 =encoding UTF-8
 240
 241 =head1 NAME
 242
 243 App::FatPacker - pack your dependencies onto your script file
 244
 245 =head1 SYNOPSIS
 246
 247   $ fatpack trace myscript.pl
 248   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 249   $ fatpack tree `cat packlists`
 250   $ (fatpack file; cat myscript.pl) >myscript.packed.pl
 251
 252 See the documentation for the L<fatpack> script itself for more information.
 253
 254 The programmatic API for this code is not yet fully decided, hence the 0.9
 255 release version. Expect that to be cleaned up for 1.0.
 256
 257 =head1 SUPPORT
 258
 259 Your current best avenue is to come annoy annoy mst on #toolchain on
 260 irc.perl.org. There should be a non-IRC means of support by 1.0.
 261
 262 =head1 AUTHOR
 263
 264 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 265
 266 =head2 CONTRIBUTORS
 267
 268 miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) <miyagawa@bulknews.net>
 269
 270 tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) <tokuhirom@gmail.com>
 271
 272 dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
 273
 274 gugod - 劉康民 (cpan:GUGOD) <gugod@cpan.org>
 275
 276 t0m - Tomas Doran (cpan:BOBTFISH) <bobtfish@bobtfish.net>
 277
 278 sawyer - Sawyer X (cpan:XSAWYERX) <xsawyerx@cpan.org>
 279
 280 ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 281
 282 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
 283
 284 Many more people are probably owed thanks for ideas. Yet
 285 another doc nit to fix.
 286
 287 =head1 COPYRIGHT
 288
 289 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 290 as listed above.
 291
 292 =head1 LICENSE
 293
 294 This library is free software and may be distributed under the same terms
 295 as perl itself.
 296
 297 =cut
 298
 299 1;
 300