X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=33a1f955e865bbfaa8377006fa278df7e6b2ec7c;hb=a976705b258644247534f58f1dba0318f62bbdbc;hp=1ba59771652cc998021873a0edc9aea4f397a298;hpb=48af19392722b81e946c81bfaa558c1300a13c6e;p=p5sagit%2FApp-FatPacker.git diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index 1ba5977..33a1f95 100644 --- a/lib/App/FatPacker.pm +++ b/lib/App/FatPacker.pm @@ -2,6 +2,7 @@ package App::FatPacker; use strict; use warnings FATAL => 'all'; +use 5.008001; use Getopt::Long; use Cwd qw(cwd); use File::Find qw(find); @@ -9,17 +10,21 @@ use File::Spec::Functions qw( catdir splitpath splitdir catpath rel2abs abs2rel ); use File::Copy qw(copy); -use File::Path qw(make_path remove_tree); +use File::Path qw(mkpath rmtree); use B qw(perlstring); -my $option_parser = Getopt::Long::Parser->new( - config => [ qw(require_order pass_through bundling no_auto_abbrev) ] -); +our $VERSION = '0.009007'; # 0.9.7 + +$VERSION = eval $VERSION; sub call_parser { - local *ARGV = [ @{$_[0]} ]; - $option_parser->getoptions(@{$_[1]}); - [ @ARGV ]; + my $self = shift; + my ($args, $options) = @_; + + local *ARGV = [ @{$args} ]; + $self->{option_parser}->getoptions(@$options); + + return [ @ARGV ]; } sub lines_of { @@ -32,21 +37,24 @@ sub stripspace { $text; } -our $VERSION = '0.009001'; # 0.9.1 - -$VERSION = eval $VERSION; - sub import { - $_[1] eq '-run_script' + $_[1] && $_[1] eq '-run_script' and return shift->new->run_script; } -sub new { bless({}, $_[0]) } +sub new { + bless { + option_parser => Getopt::Long::Parser->new( + config => [ qw(require_order pass_through bundling no_auto_abbrev) ] + ), + }, $_[0]; +} sub run_script { my ($self, $args) = @_; my @args = $args ? @$args : @ARGV; - (my $cmd = shift @args) =~ s/-/_/g; + (my $cmd = shift @args || 'help') =~ s/-/_/g; + if (my $meth = $self->can("script_command_${cmd}")) { $self->$meth(\@args); } else { @@ -54,32 +62,64 @@ sub run_script { } } +sub script_command_help { + print "Try `perldoc fatpack` for how to use me\n"; +} + sub script_command_trace { my ($self, $args) = @_; - - $args = call_parser $args => [ + + $args = $self->call_parser($args => [ 'to=s' => \my $file, 'to-stderr' => \my $to_stderr, - ]; + 'use=s' => \my @additional_use + ]); die "Can't use to and to-stderr on same call" if $file && $to_stderr; - (my $use_file = $file) ||= 'fatpacker.trace'; - if (!$to_stderr and -e $use_file) { - unlink $use_file or die "Couldn't remove old trace file: $!"; + $file ||= 'fatpacker.trace'; + + if (!$to_stderr and -e $file) { + unlink $file or die "Couldn't remove old trace file: $!"; } my $arg = do { - if ($file) { - "=>>${file}" - } elsif ($to_stderr) { - "=>&STDERR" - } else { - "" + if ($to_stderr) { + "=&STDERR" + } elsif ($file) { + ">>${file}" } }; - { - local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace'.$arg; - system $^X, @$args; + + $self->trace( + use => \@additional_use, + args => $args, + output => $arg, + ); +} + +sub trace { + my ($self, %opts) = @_; + + my $capture; + + my $output = $opts{output} || do { + $capture++; '>&STDOUT' + }; + + my $trace_opts = join ',', $output||'>&STDOUT', @{$opts{use}||[]}; + + local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace='.$trace_opts; + + my @args = @{$opts{args}||[]}; + + if ($output) { + # user specified output target, JFDI + system $^X, @args; + return; + } else { + # no output target specified, slurp + open my $out_fh, '-|', $^X, @args; + return do { local $/; <$out_fh> }; } } @@ -93,7 +133,9 @@ sub script_command_packlists_for { sub packlists_containing { my ($self, $targets) = @_; my @targets = @$targets; - require $_ for @targets; + foreach my $t (@targets) { + require $t; + } my @search = grep -d $_, map catdir($_, 'auto'), @INC; my %pack_rev; my $cwd = cwd; @@ -102,7 +144,7 @@ sub packlists_containing { $pack_rev{$_} = $File::Find::name for lines_of $File::Find::name; }, @search); chdir($cwd) or die "Couldn't chdir back to ${cwd} after find: $!"; - my %found; @found{map $pack_rev{$INC{$_}}, @targets} = (); + my %found; @found{map +($pack_rev{$INC{$_}}||()), @targets} = (); sort keys %found; } @@ -114,8 +156,8 @@ sub script_command_tree { sub packlists_to_tree { my ($self, $where, $packlists) = @_; - remove_tree $where; - make_path $where; + rmtree $where; + mkpath $where; foreach my $pl (@$packlists) { my ($vol, $dirs, $file) = splitpath $pl; my @dir_parts = splitdir $dirs; @@ -134,7 +176,7 @@ sub packlists_to_tree { next unless substr($source,0,length $pack_base) eq $pack_base; my $target = rel2abs( abs2rel($source, $pack_base), $where ); my $target_dir = catpath((splitpath $target)[0,1]); - make_path $target_dir; + mkpath $target_dir; copy $source => $target; } } @@ -166,7 +208,8 @@ sub script_command_file { unshift @INC, sub { if (my $fat = $fatpacked{$_[1]}) { - open my $fh, '<', \$fat; + open my $fh, '<', \$fat + or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return @@ -177,10 +220,54 @@ sub script_command_file { my @segments = map { (my $stub = $_) =~ s/\.pm$//; my $name = uc join '_', split '/', $stub; - my $data = $files{$_}; $data =~ s/^/ /mg; + my $data = $files{$_}; $data =~ s/^/ /mg; $data =~ s/(?packlists + $ fatpack tree `cat packlists` + $ (fatpack file; cat myscript.pl) >myscript.packed.pl + +See the documentation for the L script itself for more information. + +The programmatic API for this code is not yet fully decided, hence the 0.9 +release version. Expect that to be cleaned up for 1.0. + +=head1 SUPPORT + +Your current best avenue is to come annoy annoy mst on #toolchain on +irc.perl.org. There should be a non-IRC means of support by 1.0. + +=head1 AUTHOR + +Matt S. Trout (mst) + +=head2 CONTRIBUTORS + +None as yet, though I probably owe lots of people thanks for ideas. Yet +another doc nit to fix. + +=head1 COPYRIGHT + +Copyright (c) 2010 the App::FatPacker L and L +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. + +=cut + 1; +