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