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