From: Matt S Trout <mst@shadowcat.co.uk>
Date: Fri, 19 Mar 2010 06:46:33 +0000 (+0000)
Subject: initial import of skeleton code
X-Git-Tag: v0.9.4~16
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=48af19392722b81e946c81bfaa558c1300a13c6e;p=p5sagit%2FApp-FatPacker.git

initial import of skeleton code
---

48af19392722b81e946c81bfaa558c1300a13c6e
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..50d1c5c
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1 @@
+use inc::Distar;
diff --git a/inc/Distar.pm b/inc/Distar.pm
new file mode 100644
index 0000000..4c628a5
--- /dev/null
+++ b/inc/Distar.pm
@@ -0,0 +1,39 @@
+package        # in case this escapes being no_index'ed in META.yml
+  inc::Distar; # this horrible little trick hides us from PAUSE. INVISIBUL!
+
+use strict;
+use warnings FATAL => 'all';
+
+my $already;
+
+my $AUTHOR;
+
+my @do;
+
+my %whoami;
+
+sub import {
+  die "Can't call import() twice, last called from: ${already}"
+    if $already;
+  $already = join(' ', caller);
+  strict->import;
+  warnings->import(FATAL => 'all');
+  my $class = shift;
+  if (-e 'inc/whoami.pm') {
+    %whoami = %{do 'inc/whoami.pm' or die "Failed to eval inc/whoami.pm: $@"};
+  } else {
+    $AUTHOR = 1;
+    require inc::Distar::Guesswork;
+    %whoami = %{inc::Distar::Guesswork::guess(@_)};
+  }
+  push @do, sub {
+    require ExtUtils::MakeMaker;
+    ExtUtils::MakeMaker::WriteMakefile(%whoami)
+  };
+}
+
+END {
+  foreach my $do (@do) { $do->() }
+}
+
+1;
diff --git a/inc/Distar/Guesswork.pm b/inc/Distar/Guesswork.pm
new file mode 100644
index 0000000..2d5ece8
--- /dev/null
+++ b/inc/Distar/Guesswork.pm
@@ -0,0 +1,19 @@
+package inc::Distar::Guesswork;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Cwd qw(cwd);
+use File::Spec::Functions qw(splitdir catdir catfile);
+
+sub guess {
+  my $here = (splitdir cwd)[-1];
+  my @parts = split('-', $here);
+  my $last = pop @parts;
+  {
+    NAME => join('::',@parts,$last),
+    VERSION_FROM => catfile(catdir('lib', @parts), "${last}.pm"),
+  }
+}
+
+1;
diff --git a/lib/App/FatPacker.pm b/lib/App/FatPacker.pm
new file mode 100644
index 0000000..1ba5977
--- /dev/null
+++ b/lib/App/FatPacker.pm
@@ -0,0 +1,186 @@
+package App::FatPacker;
+
+use strict;
+use warnings FATAL => 'all';
+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::Copy qw(copy);
+use File::Path qw(make_path remove_tree);
+use B qw(perlstring);
+
+my $option_parser = Getopt::Long::Parser->new(
+  config => [ qw(require_order pass_through bundling no_auto_abbrev) ]
+);
+
+sub call_parser {
+  local *ARGV = [ @{$_[0]} ];
+  $option_parser->getoptions(@{$_[1]});
+  [ @ARGV ];
+}
+
+sub lines_of {
+  map +(chomp,$_)[1], do { local @ARGV = ($_[0]); <> };
+}
+
+sub stripspace {
+  my ($text) = @_;
+  $text =~ /^(\s+)/ && $text =~ s/^$1//mg;
+  $text;
+}
+
+our $VERSION = '0.009001'; # 0.9.1
+
+$VERSION = eval $VERSION;
+
+sub import {
+  $_[1] eq '-run_script'
+    and return shift->new->run_script;
+}
+
+sub new { bless({}, $_[0]) }
+
+sub run_script {
+  my ($self, $args) = @_;
+  my @args = $args ? @$args : @ARGV;
+  (my $cmd = shift @args) =~ s/-/_/g;
+  if (my $meth = $self->can("script_command_${cmd}")) {
+    $self->$meth(\@args);
+  } else {
+    die "No such command ${cmd}";
+  }
+}
+
+sub script_command_trace {
+  my ($self, $args) = @_;
+  
+  $args = call_parser $args => [
+    'to=s' => \my $file,
+    'to-stderr' => \my $to_stderr,
+  ];
+
+  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: $!";
+  }
+  my $arg = do {
+    if ($file) {
+      "=>>${file}"
+    } elsif ($to_stderr) {
+      "=>&STDERR"
+    } else {
+      ""
+    }
+  };
+  {
+    local $ENV{PERL5OPT} = '-MApp::FatPacker::Trace'.$arg;
+    system $^X, @$args;
+  }
+}
+
+sub script_command_packlists_for {
+  my ($self, $args) = @_;
+  foreach my $pl ($self->packlists_containing($args)) {
+    print "${pl}\n";
+  }
+}
+
+sub packlists_containing {
+  my ($self, $targets) = @_;
+  my @targets = @$targets;
+  require $_ for @targets;
+  my @search = grep -d $_, map catdir($_, 'auto'), @INC;
+  my %pack_rev;
+  my $cwd = cwd;
+  find(sub {
+    return unless $_ eq '.packlist' && -f $_;
+    $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} = ();
+  sort keys %found;
+}
+
+sub script_command_tree {
+  my ($self, $args) = @_;
+  my $base = catdir(cwd,'fatlib');
+  $self->packlists_to_tree($base, $args);
+}
+
+sub packlists_to_tree {
+  my ($self, $where, $packlists) = @_;
+  remove_tree $where;
+  make_path $where;
+  foreach my $pl (@$packlists) {
+    my ($vol, $dirs, $file) = splitpath $pl;
+    my @dir_parts = splitdir $dirs;
+    my $pack_base;
+    PART: foreach my $p (0 .. $#dir_parts) {
+      if ($dir_parts[$p] eq 'auto') {
+        # $p-2 since it's <wanted path>/$Config{archname}/auto
+        $pack_base = catpath $vol, catdir @dir_parts[0..$p-2];
+        last PART;
+      }
+    }
+    die "Couldn't figure out base path of packlist ${pl}" unless $pack_base;
+    foreach my $source (lines_of $pl) {
+      # there is presumably a better way to do "is this under this base?"
+      # but if so, it's not obvious to me in File::Spec
+      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;
+      copy $source => $target;
+    }
+  }
+}
+
+sub script_command_file {
+  my ($self, $args) = @_;
+  my $file = shift @$args;
+  my $cwd = cwd;
+  my @dirs = map rel2abs($_, $cwd), ('lib','fatlib');
+  my %files;
+  foreach my $dir (@dirs) {
+    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 {
+        local (@ARGV, $/) = ($File::Find::name); <>
+      };
+    }, $dir);
+  }
+  my $start = stripspace <<'  END_START';
+    # This chunk of stuff was generated by App::FatPacker. To find the original
+    # file's code, look for the end of this BEGIN block or the string 'FATPACK'
+    BEGIN {
+    my %fatpacked;
+  END_START
+  my $end = stripspace <<'  END_END';
+    s/^  //mg for values %fatpacked;
+
+    unshift @INC, sub {
+      if (my $fat = $fatpacked{$_[1]}) {
+        open my $fh, '<', \$fat;
+        return $fh;
+      }
+      return
+    };
+
+    } # END OF FATPACK CODE
+  END_END
+  my @segments = map {
+    (my $stub = $_) =~ s/\.pm$//;
+    my $name = uc join '_', split '/', $stub;
+    my $data = $files{$_}; $data =~ s/^/  /mg;
+    '$fatpacked{'.perlstring($_).qq!} = <<'${name}';\n!
+    .qq!${data}${name}\n!;
+  } sort keys %files;
+  print join "\n", $start, @segments, $end;
+}
+1;
diff --git a/lib/App/FatPacker/Trace.pm b/lib/App/FatPacker/Trace.pm
new file mode 100644
index 0000000..6d1f68a
--- /dev/null
+++ b/lib/App/FatPacker/Trace.pm
@@ -0,0 +1,17 @@
+package App::FatPacker::Trace;
+
+use strict;
+use warnings FATAL => 'all';
+use B ();
+
+sub import {
+  my $open = $_[1] || '>>fatpacker.trace';
+  open my $trace, $open
+    or die "Couldn't open ${open} to trace to: $!";
+  unshift @INC, sub {
+    print $trace "$_[1]\n";
+  };
+  B::minus_c;
+}
+
+1;
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..6e97616
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,8 @@
+use strict;
+use warnings FATAL => 'all';
+use Test::More qw(no_plan);
+
+require App::FatPacker;
+require App::FatPacker::Trace;
+
+pass "Didn't blow up";