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(make_path remove_tree);
  14 use B qw(perlstring);
  15
  16 our $VERSION = '0.009005'; # 0.9.5
  17
  18 $VERSION = eval $VERSION;
  19
  20 my $option_parser = Getopt::Long::Parser->new(
  21   config => [ qw(require_order pass_through bundling no_auto_abbrev) ]
  22 );
  23
  24 sub call_parser {
  25   local *ARGV = [ @{$_[0]} ];
  26   $option_parser->getoptions(@{$_[1]});
  27   [ @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] eq '-run_script'
  42     and return shift->new->run_script;
  43 }
  44
  45 sub new { bless({}, $_[0]) }
  46
  47 sub run_script {
  48   my ($self, $args) = @_;
  49   my @args = $args ? @$args : @ARGV;
  50   (my $cmd = shift @args || 'help') =~ s/-/_/g;
  51   if (my $meth = $self->can("script_command_${cmd}")) {
  52     $self->$meth(\@args);
  53   } else {
  54     die "No such command ${cmd}";
  55   }
  56 }
  57
  58 sub script_command_help {
  59   print "Try `perldoc fatpack` for how to use me\n";
  60 }
  61
  62 sub script_command_trace {
  63   my ($self, $args) = @_;
  64
  65   $args = call_parser $args => [
  66     'to=s' => \my $file,
  67     'to-stderr' => \my $to_stderr,
  68   ];
  69
  70   die "Can't use to and to-stderr on same call" if $file && $to_stderr;
  71
  72   (my $use_file = $file) ||= 'fatpacker.trace';
  73   if (!$to_stderr and -e $use_file) {
  74     unlink $use_file or die "Couldn't remove old trace file: $!";
  75   }
  76   my $arg = do {
  77     if ($file) {
  78       "=>>${file}"
  79     } elsif ($to_stderr) {
  80       "=>&STDERR"
  81     } else {
  82       ""
  83     }
  84   };
  85   {
  86     local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace'.$arg;
  87     system $^X, @$args;
  88   }
  89 }
  90
  91 sub script_command_packlists_for {
  92   my ($self, $args) = @_;
  93   foreach my $pl ($self->packlists_containing($args)) {
  94     print "${pl}\n";
  95   }
  96 }
  97
  98 sub packlists_containing {
  99   my ($self, $targets) = @_;
 100   my @targets = @$targets;
 101   require $_ for @targets;
 102   my @search = grep -d $_, map catdir($_, 'auto'), @INC;
 103   my %pack_rev;
 104   my $cwd = cwd;
 105   find(sub {
 106     return unless $_ eq '.packlist' && -f $_;
 107     $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name;
 108   }, @search);
 109   chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!";
 110   my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = ();
 111   sort keys %found;
 112 }
 113
 114 sub script_command_tree {
 115   my ($self, $args) = @_;
 116   my $base = catdir(cwd,'fatlib');
 117   $self->packlists_to_tree($base, $args);
 118 }
 119
 120 sub packlists_to_tree {
 121   my ($self, $where, $packlists) = @_;
 122   remove_tree $where;
 123   make_path $where;
 124   foreach my $pl (@$packlists) {
 125     my ($vol, $dirs, $file) = splitpath $pl;
 126     my @dir_parts = splitdir $dirs;
 127     my $pack_base;
 128     PART: foreach my $p (0 .. $#dir_parts) {
 129       if ($dir_parts[$p] eq 'auto') {
 130         # $p-2 since it's <wanted path>/$Config{archname}/auto
 131         $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
 132         last PART;
 133       }
 134     }
 135     die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
 136     foreach my $source (lines_of $pl) {
 137       # there is presumably a better way to do "is this under this base?"
 138       # but if so, it's not obvious to me in File::Spec
 139       next unless substr($source,0,length $pack_base) eq $pack_base;
 140       my $target = rel2abs( abs2rel($source, $pack_base), $where );
 141       my $target_dir = catpath((splitpath $target)[0,1]);
 142       make_path $target_dir;
 143       copy $source => $target;
 144     }
 145   }
 146 }
 147
 148 sub script_command_file {
 149   my ($self, $args) = @_;
 150   my $file = shift @$args;
 151   my $cwd = cwd;
 152   my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
 153   my %files;
 154   foreach my $dir (@dirs) {
 155     find(sub {
 156       return unless -f $_;
 157       !/\.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;
 158       $files{abs2rel($File::Find::name,$dir)} = do {
 159         local (@ARGV, $/) = ($File::Find::name); <>
 160       };
 161     }, $dir);
 162   }
 163   my $start = stripspace <<'  END_START';
 164     # This chunk of stuff was generated by App::FatPacker. To find the original
 165     # file's code, look for the end of this BEGIN block or the string 'FATPACK'
 166     BEGIN {
 167     my %fatpacked;
 168   END_START
 169   my $end = stripspace <<'  END_END';
 170     s/^  //mg for values %fatpacked;
 171
 172     unshift @INC, sub {
 173       if (my $fat = $fatpacked{$_[1]}) {
 174         open my $fh, '<', \$fat
 175           or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
 176         return $fh;
 177       }
 178       return
 179     };
 180
 181     } # END OF FATPACK CODE
 182   END_END
 183   my @segments = map {
 184     (my $stub = $_) =~ s/\.pm$//;
 185     my $name = uc join '_', split '/', $stub;
 186     my $data = $files{$_}; $data =~ s/^/  /mg; $data =~ s/(?<!\n)\z/\n/;
 187     '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
 188     .qq!${data}${name}\n!;
 189   } sort keys %files;
 190   print join "\n", $start, @segments, $end;
 191 }
 192
 193 =head1 NAME
 194
 195 App::FatPacker - pack your dependencies onto your script file
 196
 197 =head1 SYNOPSIS
 198
 199   $ fatpack trace myscript.pl
 200   $ fatpack packlists-for `cat fatpacker.trace` >packlists
 201   $ fatpack tree `cat packlists`
 202   $ (fatpack file; cat myscript.pl) >myscript.packed.pl
 203
 204 See the documentation for the L<fatpack> script itself for more information.
 205
 206 The programmatic API for this code is not yet fully decided, hence the 0.9.1
 207 release version. Expect that to be cleaned up for 1.0.
 208
 209 =head1 SUPPORT
 210
 211 Your current best avenue is to come annoy annoy mst on #toolchain on
 212 irc.perl.org. There should be a non-IRC means of support by 1.0.
 213
 214 =head1 AUTHOR
 215
 216 Matt S. Trout (mst) <mst@shadowcat.co.uk>
 217
 218 =head2 CONTRIBUTORS
 219
 220 None as yet, though I probably owe lots of people thanks for ideas. Yet
 221 another doc nit to fix.
 222
 223 =head1 COPYRIGHT
 224
 225 Copyright (c) 2010 the App::FatPacker L</AUTHOR> and L</CONTRIBUTORS>
 226 as listed above.
 227
 228 =head1 LICENSE
 229
 230 This library is free software and may be distributed under the same terms
 231 as perl itself.
 232
 233 =cut
 234
 235 1;