X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FApp%2FFatPacker.pm;h=03d28fbf2dd5292f0f4f1ba717bca0b5a6f2d4ea;hb=bb49414d002fe7f1b61e57f961ebb6d1b246814d;hp=1ba59771652cc998021873a0edc9aea4f397a298;hpb=48af19392722b81e946c81bfaa558c1300a13c6e;p=p5sagit%2FApp-FatPacker.git diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm index 1ba5977..03d28fb 100644 --- a/lib/App/FatPacker.pm +++ b/lib/App/FatPacker.pm @@ -2,24 +2,30 @@ package App::FatPacker; use strict; use warnings FATAL => 'all'; +use 5.008001; use Getopt::Long; use Cwd qw(cwd); use File::Find qw(find); use File::Spec::Functions qw( catdir splitpath splitdir catpath rel2abs abs2rel ); +use File::Spec::Unix; 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.009009'; # 0.9.9 + +$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 +38,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 +63,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 +134,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 +145,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 +157,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 +177,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; } } @@ -150,9 +193,10 @@ sub script_command_file { find(sub { return unless -f $_; !/\.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; - $files{abs2rel($File::Find::name,$dir)} = do { + $files{File::Spec::Unix->abs2rel($File::Find::name,$dir)} = do { local (@ARGV, $/) = ($File::Find::name); <> }; + close ARGV; }, $dir); } my $start = stripspace <<' END_START'; @@ -166,7 +210,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 +222,72 @@ 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 + +miyagawa - Tatsuhiko Miyagawa (cpan:MIYAGAWA) + +tokuhirom - MATSUNO★Tokuhiro (cpan:TOKUHIROM) + +dg - David Leadbeater (cpan:DGL) + +gugod - 劉康民 (cpan:GUGOD) + +t0m - Tomas Doran (cpan:BOBTFISH) + +sawyer - Sawyer X (cpan:XSAWYERX) + +ether - Karen Etheridge (cpan:ETHER) + +Mithaldu - Christian Walde (cpan:MITHALDU) + +Many more people are probably owed 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; +