package Tak::STDIONode;
our $DATA = do { local $/; <DATA> };
1;
__DATA__

# 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;

$fatpacked{"Algorithm/C3.pm"} = <<'ALGORITHM_C3';
  
  package Algorithm::C3;
  
  use strict;
  use warnings;
  
  use Carp 'confess';
  
  our $VERSION = '0.08';
  
  sub merge {
      my ($root, $parent_fetcher, $cache) = @_;
  
      $cache ||= {};
  
      my @STACK; # stack for simulating recursion
  
      my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
  
      unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
          confess "Could not find method $parent_fetcher in $root";
      }
  
      my $current_root = $root;
      my $current_parents = [ $root->$parent_fetcher ];
      my $recurse_mergeout = [];
      my $i = 0;
      my %seen = ( $root => 1 );
  
      my ($new_root, $mergeout, %tails);
      while(1) {
          if($i < @$current_parents) {
              $new_root = $current_parents->[$i++];
  
              if($seen{$new_root}) {
                  my @isastack;
                  my $reached;
                  for(my $i = 0; $i < $#STACK; $i += 4) {
                      if($reached || ($reached = ($STACK[$i] eq $new_root))) {
                          push(@isastack, $STACK[$i]);
                      }
                  }
                  my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
                  die "Infinite loop detected in parents of '$root': $isastack";
              }
              $seen{$new_root} = 1;
  
              unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
                  confess "Could not find method $parent_fetcher in $new_root";
              }
  
              push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
  
              $current_root = $new_root;
              $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
              $recurse_mergeout = [];
              $i = 0;
              next;
          }
  
          $seen{$current_root} = 0;
  
          $mergeout = $cache->{merge}->{$current_root} ||= do {
  
              # This do-block is the code formerly known as the function
              # that was a perl-port of the python code at
              # http://www.python.org/2.3/mro.html :)
  
              # Initial set (make sure everything is copied - it will be modded)
              my @seqs = map { [@$_] } @$recurse_mergeout;
              push(@seqs, [@$current_parents]) if @$current_parents;
  
              # Construct the tail-checking hash (actually, it's cheaper and still
              #   correct to re-use it throughout this function)
              foreach my $seq (@seqs) {
                  $tails{$seq->[$_]}++ for (1..$#$seq);
              }
  
              my @res = ( $current_root );
              while (1) {
                  my $cand;
                  my $winner;
                  foreach (@seqs) {
                      next if !@$_;
                      if(!$winner) {              # looking for a winner
                          $cand = $_->[0];        # seq head is candidate
                          next if $tails{$cand};  # he loses if in %tails
  
                          # Handy warn to give a output like the ones on
                          # http://www.python.org/download/releases/2.3/mro/
                          #warn " = " . join(' + ', @res) . "  + merge([" . join('] [',  map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
                          push @res => $winner = $cand;
                          shift @$_;                # strip off our winner
                          $tails{$_->[0]}-- if @$_; # keep %tails sane
                      }
                      elsif($_->[0] eq $winner) {
                          shift @$_;                # strip off our winner
                          $tails{$_->[0]}-- if @$_; # keep %tails sane
                      }
                  }
  
                  # Handy warn to give a output like the ones on
                  # http://www.python.org/download/releases/2.3/mro/
                  #warn " = " . join(' + ', @res) . "\n" if !$cand;
  
                  last if !$cand;
                  die q{Inconsistent hierarchy found while merging '}
                      . $current_root . qq{':\n\t}
                      . qq{current merge results [\n\t\t}
                      . (join ",\n\t\t" => @res)
                      . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
                    if !$winner;
              }
              \@res;
          };
  
          return @$mergeout if !@STACK;
  
          $i = pop(@STACK);
          $recurse_mergeout = pop(@STACK);
          $current_parents = pop(@STACK);
          $current_root = pop(@STACK);
  
          push(@$recurse_mergeout, $mergeout);
      }
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
  
  =head1 SYNOPSIS
  
    use Algorithm::C3;
  
    # merging a classic diamond
    # inheritance graph like this:
    #
    #    <A>
    #   /   \
    # <B>   <C>
    #   \   /
    #    <D>
  
    my @merged = Algorithm::C3::merge(
        'D',
        sub {
            # extract the ISA array
            # from the package
            no strict 'refs';
            @{$_[0] . '::ISA'};
        }
    );
  
    print join ", " => @merged; # prints D, B, C, A
  
  =head1 DESCRIPTION
  
  This module implements the C3 algorithm. I have broken this out
  into it's own module because I found myself copying and pasting
  it way too often for various needs. Most of the uses I have for
  C3 revolve around class building and metamodels, but it could
  also be used for things like dependency resolution as well since
  it tends to do such a nice job of preserving local precedence
  orderings.
  
  Below is a brief explanation of C3 taken from the L<Class::C3>
  module. For more detailed information, see the L<SEE ALSO> section
  and the links there.
  
  =head2 What is C3?
  
  C3 is the name of an algorithm which aims to provide a sane method
  resolution order under multiple inheritance. It was first introduced
  in the language Dylan (see links in the L<SEE ALSO> section), and
  then later adopted as the preferred MRO (Method Resolution Order)
  for the new-style classes in Python 2.3. Most recently it has been
  adopted as the 'canonical' MRO for Perl 6 classes, and the default
  MRO for Parrot objects as well.
  
  =head2 How does C3 work.
  
  C3 works by always preserving local precedence ordering. This
  essentially means that no class will appear before any of it's
  subclasses. Take the classic diamond inheritance pattern for
  instance:
  
       <A>
      /   \
    <B>   <C>
      \   /
       <D>
  
  The standard Perl 5 MRO would be (D, B, A, C). The result being that
  B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
  The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
  which does not have this same issue.
  
  This example is fairly trivial, for more complex examples and a deeper
  explanation, see the links in the L<SEE ALSO> section.
  
  =head1 FUNCTION
  
  =over 4
  
  =item B<merge ($root, $func_to_fetch_parent, $cache)>
  
  This takes a C<$root> node, which can be anything really it
  is up to you. Then it takes a C<$func_to_fetch_parent> which
  can be either a CODE reference (see L<SYNOPSIS> above for an
  example), or a string containing a method name to be called
  on all the items being linearized. An example of how this
  might look is below:
  
    {
        package A;
  
        sub supers {
            no strict 'refs';
            @{$_[0] . '::ISA'};
        }
  
        package C;
        our @ISA = ('A');
        package B;
        our @ISA = ('A');
        package D;
        our @ISA = ('B', 'C');
    }
  
    print join ", " => Algorithm::C3::merge('D', 'supers');
  
  The purpose of C<$func_to_fetch_parent> is to provide a way
  for C<merge> to extract the parents of C<$root>. This is
  needed for C3 to be able to do it's work.
  
  The C<$cache> parameter is an entirely optional performance
  measure, and should not change behavior.
  
  If supplied, it should be a hashref that merge can use as a
  private cache between runs to speed things up.  Generally
  speaking, if you will be calling merge many times on related
  things, and the parent fetching function will return constant
  results given the same arguments during all of these calls,
  you can and should reuse the same shared cache hash for all
  of the calls.  Example:
  
    sub do_some_merging {
        my %merge_cache;
        my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
        my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
        my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
        my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
        # ...
    }
  
  =back
  
  =head1 CODE COVERAGE
  
  I use B<Devel::Cover> to test the code coverage of my tests, below
  is the B<Devel::Cover> report on this module's test suite.
  
   ------------------------ ------ ------ ------ ------ ------ ------ ------
   File                       stmt   bran   cond    sub    pod   time  total
   ------------------------ ------ ------ ------ ------ ------ ------ ------
   Algorithm/C3.pm           100.0  100.0  100.0  100.0  100.0  100.0  100.0
   ------------------------ ------ ------ ------ ------ ------ ------ ------
   Total                     100.0  100.0  100.0  100.0  100.0  100.0  100.0
   ------------------------ ------ ------ ------ ------ ------ ------ ------
  
  =head1 SEE ALSO
  
  =head2 The original Dylan paper
  
  =over 4
  
  =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
  
  =back
  
  =head2 The prototype Perl 6 Object Model uses C3
  
  =over 4
  
  =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
  
  =back
  
  =head2 Parrot now uses C3
  
  =over 4
  
  =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
  
  =item L<http://use.perl.org/~autrijus/journal/25768>
  
  =back
  
  =head2 Python 2.3 MRO related links
  
  =over 4
  
  =item L<http://www.python.org/2.3/mro.html>
  
  =item L<http://www.python.org/2.2.2/descrintro.html#mro>
  
  =back
  
  =head2 C3 for TinyCLOS
  
  =over 4
  
  =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
  
  =back
  
  =head1 AUTHORS
  
  Stevan Little, E<lt>stevan@iinteractive.comE<gt>
  
  Brandon L. Black, E<lt>blblack@gmail.comE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2006 by Infinity Interactive, Inc.
  
  L<http://www.iinteractive.com>
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
ALGORITHM_C3

$fatpacked{"App/Tak.pm"} = <<'APP_TAK';
  package App::Tak;
  
  use Moo;
  
  has env => (is => 'ro', required => 1);
  
  sub new_from_environment {
    my $class = shift;
    my %env = (
      env => { %ENV }, argv => [ @ARGV ],
      stdin => \*STDIN, stdout => \*STDOUT, stderr => \*STDERR
    );
    $class->new(env => \%env);
  }
  
  sub run {
    my ($self) = @_;
    my @argv = @{$self->env->{argv}};
    require Tak::MyScript;
    my $opt = Tak::MyScript->_parse_options(
      'config|c=s;host|h=s@;local|l!;verbose|v+;quiet|q+', \@argv
    );
    Tak::MyScript->new(
      options => $opt,
      env => { %{$self->env}, argv => \@argv }
    )->run;
  }
  
  1;
APP_TAK

$fatpacked{"Capture/Tiny.pm"} = <<'CAPTURE_TINY';
  #
  # This file is part of Capture-Tiny
  #
  # This software is Copyright (c) 2009 by David Golden.
  #
  # This is free software, licensed under:
  #
  #   The Apache License, Version 2.0, January 2004
  #
  use 5.006;
  use strict;
  use warnings;
  package Capture::Tiny;
  BEGIN {
    $Capture::Tiny::VERSION = '0.11';
  }
  # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
  use Carp ();
  use Exporter ();
  use IO::Handle ();
  use File::Spec ();
  use File::Temp qw/tempfile tmpnam/;
  # Get PerlIO or fake it
  BEGIN {
    local $@;
    eval { require PerlIO; PerlIO->can('get_layers') }
      or *PerlIO::get_layers = sub { return () };
  }
  
  our @ISA = qw/Exporter/;
  our @EXPORT_OK = qw/capture capture_merged tee tee_merged/;
  our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
  
  my $IS_WIN32 = $^O eq 'MSWin32';
  
  our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
  my $DEBUGFH;
  open $DEBUGFH, ">&STDERR" if $DEBUG;
  
  *_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};
  
  our $TIMEOUT = 30;
  
  #--------------------------------------------------------------------------#
  # command to tee output -- the argument is a filename that must
  # be opened to signal that the process is ready to receive input.
  # This is annoying, but seems to be the best that can be done
  # as a simple, portable IPC technique
  #--------------------------------------------------------------------------#
  my @cmd = ($^X, '-e', '$SIG{HUP}=sub{exit}; '
    . 'if( my $fn=shift ){ open my $fh, qq{>$fn}; print {$fh} $$; close $fh;} '
    . 'my $buf; while (sysread(STDIN, $buf, 2048)) { '
    . 'syswrite(STDOUT, $buf); syswrite(STDERR, $buf)}'
  );
  
  #--------------------------------------------------------------------------#
  # filehandle manipulation
  #--------------------------------------------------------------------------#
  
  sub _relayer {
    my ($fh, $layers) = @_;
    _debug("# requested layers (@{$layers}) to $fh\n");
    my %seen = ( unix => 1, perlio => 1 ); # filter these out
    my @unique = grep { !$seen{$_}++ } @$layers;
    _debug("# applying unique layers (@unique) to $fh\n");
    binmode($fh, join(":", ":raw", @unique));
  }
  
  sub _name {
    my $glob = shift;
    no strict 'refs'; ## no critic
    return *{$glob}{NAME};
  }
  
  sub _open {
    open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
    _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
  }
  
  sub _close {
    close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
    _debug( "# closed " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . "\n" );
  }
  
  my %dup; # cache this so STDIN stays fd0
  my %proxy_count;
  sub _proxy_std {
    my %proxies;
    if ( ! defined fileno STDIN ) {
      $proxy_count{stdin}++;
      if (defined $dup{stdin}) {
        _open \*STDIN, "<&=" . fileno($dup{stdin});
        _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
      }
      else {
        _open \*STDIN, "<" . File::Spec->devnull;
        _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
        _open $dup{stdin} = IO::Handle->new, "<&=STDIN";
      }
      $proxies{stdin} = \*STDIN;
      binmode(STDIN, ':utf8') if $] >= 5.008;
    }
    if ( ! defined fileno STDOUT ) {
      $proxy_count{stdout}++;
      if (defined $dup{stdout}) {
        _open \*STDOUT, ">&=" . fileno($dup{stdout});
        _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
      }
      else {
        _open \*STDOUT, ">" . File::Spec->devnull;
        _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
        _open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
      }
      $proxies{stdout} = \*STDOUT;
      binmode(STDOUT, ':utf8') if $] >= 5.008;
    }
    if ( ! defined fileno STDERR ) {
      $proxy_count{stderr}++;
      if (defined $dup{stderr}) {
        _open \*STDERR, ">&=" . fileno($dup{stderr});
        _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
      }
      else {
        _open \*STDERR, ">" . File::Spec->devnull;
        _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
        _open $dup{stderr} = IO::Handle->new, ">&=STDERR";
      }
      $proxies{stderr} = \*STDERR;
      binmode(STDERR, ':utf8') if $] >= 5.008;
    }
    return %proxies;
  }
  
  sub _unproxy {
    my (%proxies) = @_;
    _debug( "# unproxing " . join(" ", keys %proxies) . "\n" );
    for my $p ( keys %proxies ) {
      $proxy_count{$p}--;
      _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
      if ( ! $proxy_count{$p} ) {
        _close $proxies{$p};
        _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
        delete $dup{$p};
      }
    }
  }
  
  sub _copy_std {
    my %handles = map { $_, IO::Handle->new } qw/stdin stdout stderr/;
    _debug( "# copying std handles ...\n" );
    _open $handles{stdin},   "<&STDIN";
    _open $handles{stdout},  ">&STDOUT";
    _open $handles{stderr},  ">&STDERR";
    return \%handles;
  }
  
  sub _open_std {
    my ($handles) = @_;
    _open \*STDIN, "<&" . fileno $handles->{stdin};
    _open \*STDOUT, ">&" . fileno $handles->{stdout};
    _open \*STDERR, ">&" . fileno $handles->{stderr};
  }
  
  #--------------------------------------------------------------------------#
  # private subs
  #--------------------------------------------------------------------------#
  
  sub _start_tee {
    my ($which, $stash) = @_;
    # setup pipes
    $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
    pipe $stash->{reader}{$which}, $stash->{tee}{$which};
    _debug( "# pipe for $which\: " .  _name($stash->{tee}{$which}) . " "
      . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which})
      . " " . fileno( $stash->{reader}{$which}) . "\n" );
    select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
    # setup desired redirection for parent and child
    $stash->{new}{$which} = $stash->{tee}{$which};
    $stash->{child}{$which} = {
      stdin   => $stash->{reader}{$which},
      stdout  => $stash->{old}{$which},
      stderr  => $stash->{capture}{$which},
    };
    # flag file is used to signal the child is ready
    $stash->{flag_files}{$which} = scalar tmpnam();
    # execute @cmd as a separate process
    if ( $IS_WIN32 ) {
      local $@;
      eval "use Win32API::File qw/CloseHandle GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
      _debug( "# Win32API::File loaded\n") unless $@;
      my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
      _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
      if ( SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0) ) {
        _debug( "# set no-inherit flag on $which tee\n" );
      }
      else {
        _debug( "# can't disable tee handle flag inherit: " . fileLastError() . "\n");
      }
      _open_std( $stash->{child}{$which} );
      $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
      # not restoring std here as it all gets redirected again shortly anyway
    }
    else { # use fork
      _fork_exec( $which, $stash );
    }
  }
  
  sub _fork_exec {
    my ($which, $stash) = @_;
    my $pid = fork;
    if ( not defined $pid ) {
      Carp::confess "Couldn't fork(): $!";
    }
    elsif ($pid == 0) { # child
      _debug( "# in child process ...\n" );
      untie *STDIN; untie *STDOUT; untie *STDERR;
      _close $stash->{tee}{$which};
      _debug( "# redirecting handles in child ...\n" );
      _open_std( $stash->{child}{$which} );
      _debug( "# calling exec on command ...\n" );
      exec @cmd, $stash->{flag_files}{$which};
    }
    $stash->{pid}{$which} = $pid
  }
  
  sub _files_exist { -f $_ || return 0 for @_; return 1 }
  
  sub _wait_for_tees {
    my ($stash) = @_;
    my $start = time;
    my @files = values %{$stash->{flag_files}};
    my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
                ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
    1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
    Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
    unlink $_ for @files;
  }
  
  sub _kill_tees {
    my ($stash) = @_;
    if ( $IS_WIN32 ) {
      _debug( "# closing handles with CloseHandle\n");
      CloseHandle( GetOsFHandle($_) ) for values %{ $stash->{tee} };
      _debug( "# waiting for subprocesses to finish\n");
      my $start = time;
      1 until wait == -1 || (time - $start > 30);
    }
    else {
      _close $_ for values %{ $stash->{tee} };
      waitpid $_, 0 for values %{ $stash->{pid} };
    }
  }
  
  sub _slurp {
    seek $_[0],0,0; local $/; return scalar readline $_[0];
  }
  
  #--------------------------------------------------------------------------#
  # _capture_tee() -- generic main sub for capturing or teeing
  #--------------------------------------------------------------------------#
  
  sub _capture_tee {
    _debug( "# starting _capture_tee with (@_)...\n" );
    my ($tee_stdout, $tee_stderr, $merge, $code) = @_;
    # save existing filehandles and setup captures
    local *CT_ORIG_STDIN  = *STDIN ;
    local *CT_ORIG_STDOUT = *STDOUT;
    local *CT_ORIG_STDERR = *STDERR;
    # find initial layers
    my %layers = (
      stdin   => [PerlIO::get_layers(\*STDIN) ],
      stdout  => [PerlIO::get_layers(\*STDOUT)],
      stderr  => [PerlIO::get_layers(\*STDERR)],
    );
    _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
    # bypass scalar filehandles and tied handles
    my %localize;
    $localize{stdin}++,  local(*STDIN)  if grep { $_ eq 'scalar' } @{$layers{stdin}};
    $localize{stdout}++, local(*STDOUT) if grep { $_ eq 'scalar' } @{$layers{stdout}};
    $localize{stderr}++, local(*STDERR) if grep { $_ eq 'scalar' } @{$layers{stderr}};
    $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if tied *STDOUT && $] >= 5.008;
    $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if tied *STDERR && $] >= 5.008;
    _debug( "# localized $_\n" ) for keys %localize;
    my %proxy_std = _proxy_std();
    _debug( "# proxy std is @{ [%proxy_std] }\n" );
    my $stash = { old => _copy_std() };
    # update layers after any proxying
    %layers = (
      stdin   => [PerlIO::get_layers(\*STDIN) ],
      stdout  => [PerlIO::get_layers(\*STDOUT)],
      stderr  => [PerlIO::get_layers(\*STDERR)],
    );
    _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
    # get handles for capture and apply existing IO layers
    $stash->{new}{$_} = $stash->{capture}{$_} = File::Temp->new for qw/stdout stderr/;
    _debug("# will capture $_ on " .fileno($stash->{capture}{$_})."\n" ) for qw/stdout stderr/;
    # tees may change $stash->{new}
    _start_tee( stdout => $stash ) if $tee_stdout;
    _start_tee( stderr => $stash ) if $tee_stderr;
    _wait_for_tees( $stash ) if $tee_stdout || $tee_stderr;
    # finalize redirection
    $stash->{new}{stderr} = $stash->{new}{stdout} if $merge;
    $stash->{new}{stdin} = $stash->{old}{stdin};
    _debug( "# redirecting in parent ...\n" );
    _open_std( $stash->{new} );
    # execute user provided code
    my ($exit_code, $inner_error, $outer_error);
    {
      local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
      local *STDERR = *STDOUT if $merge; # minimize buffer mixups during $code
      _debug( "# finalizing layers ...\n" );
      _relayer(\*STDOUT, $layers{stdout});
      _relayer(\*STDERR, $layers{stderr}) unless $merge;
      _debug( "# running code $code ...\n" );
      local $@;
      eval { $code->(); $inner_error = $@ };
      $exit_code = $?; # save this for later
      $outer_error = $@; # save this for later
    }
    # restore prior filehandles and shut down tees
    _debug( "# restoring ...\n" );
    _open_std( $stash->{old} );
    _close( $_ ) for values %{$stash->{old}}; # don't leak fds
    _unproxy( %proxy_std );
    _kill_tees( $stash ) if $tee_stdout || $tee_stderr;
    # return captured output
    _relayer($stash->{capture}{stdout}, $layers{stdout});
    _relayer($stash->{capture}{stderr}, $layers{stderr}) unless $merge;
    _debug( "# slurping captured $_ with layers: @{[PerlIO::get_layers($stash->{capture}{$_})]}\n") for qw/stdout stderr/;
    my $got_out = _slurp($stash->{capture}{stdout});
    my $got_err = $merge ? q() : _slurp($stash->{capture}{stderr});
    print CT_ORIG_STDOUT $got_out if $localize{stdout} && $tee_stdout;
    print CT_ORIG_STDERR $got_err if !$merge && $localize{stderr} && $tee_stdout;
    $? = $exit_code;
    $@ = $inner_error if $inner_error;
    die $outer_error if $outer_error;
    _debug( "# ending _capture_tee with (@_)...\n" );
    return $got_out if $merge;
    return wantarray ? ($got_out, $got_err) : $got_out;
  }
  
  #--------------------------------------------------------------------------#
  # create API subroutines from [tee STDOUT flag, tee STDERR, merge flag]
  #--------------------------------------------------------------------------#
  
  my %api = (
    capture         => [0,0,0],
    capture_merged  => [0,0,1],
    tee             => [1,1,0],
    tee_merged      => [1,0,1], # don't tee STDOUT since merging
  );
  
  for my $sub ( keys %api ) {
    my $args = join q{, }, @{$api{$sub}};
    eval "sub $sub(&) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
  }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
  
  =head1 VERSION
  
  version 0.11
  
  =head1 SYNOPSIS
  
     use Capture::Tiny qw/capture tee capture_merged tee_merged/;
   
     ($stdout, $stderr) = capture {
       # your code here
     };
   
     ($stdout, $stderr) = tee {
       # your code here
     };
   
     $merged = capture_merged {
       # your code here
     };
   
     $merged = tee_merged {
       # your code here
     };
  
  =head1 DESCRIPTION
  
  Capture::Tiny provides a simple, portable way to capture anything sent to
  STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
  from an external program.  Optionally, output can be teed so that it is
  captured while being passed through to the original handles.  Yes, it even
  works on Windows.  Stop guessing which of a dozen capturing modules to use in
  any particular situation and just use this one.
  
  This module was heavily inspired by L<IO::CaptureOutput>, which provides
  similar functionality without the ability to tee output and with more
  complicated code and API.
  
  =head1 USAGE
  
  The following functions are available.  None are exported by default.
  
  =head2 capture
  
     ($stdout, $stderr) = capture \&code;
     $stdout = capture \&code;
  
  The C<<< capture >>> function takes a code reference and returns what is sent to
  STDOUT and STDERR.  In scalar context, it returns only STDOUT.  If no output
  was received, returns an empty string.  Regardless of context, all output is
  captured -- nothing is passed to the existing handles.
  
  It is prototyped to take a subroutine reference as an argument. Thus, it
  can be called in block form:
  
     ($stdout, $stderr) = capture {
       # your code here ...
     };
  
  =head2 capture_merged
  
     $merged = capture_merged \&code;
  
  The C<<< capture_merged >>> function works just like C<<< capture >>> except STDOUT and
  STDERR are merged. (Technically, STDERR is redirected to STDOUT before
  executing the function.)  If no output was received, returns an empty string.
  As with C<<< capture >>> it may be called in block form.
  
  Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
  properly ordered due to buffering.
  
  =head2 tee
  
     ($stdout, $stderr) = tee \&code;
     $stdout = tee \&code;
  
  The C<<< tee >>> function works just like C<<< capture >>>, except that output is captured
  as well as passed on to the original STDOUT and STDERR.  As with C<<< capture >>> it
  may be called in block form.
  
  =head2 tee_merged
  
     $merged = tee_merged \&code;
  
  The C<<< tee_merged >>> function works just like C<<< capture_merged >>> except that output
  is captured as well as passed on to STDOUT.  As with C<<< capture >>> it may be called
  in block form.
  
  Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
  properly ordered due to buffering.
  
  =head1 LIMITATIONS
  
  =head2 Portability
  
  Portability is a goal, not a guarantee.  C<<< tee >>> requires fork, except on
  Windows where C<<< system(1, @cmd) >>> is used instead.  Not tested on any
  particularly esoteric platforms yet.
  
  =head2 PerlIO layers
  
  Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or
  ':crlf' when capturing.   Layers should be applied to STDOUT or STDERR I<before>
  the call to C<<< capture >>> or C<<< tee >>>.
  
  =head2 Closed STDIN, STDOUT or STDERR
  
  Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
  closed.  However, since they may be reopened to capture or tee output, any code
  within the captured block that depends on finding them closed will, of course,
  not find them to be closed.  If they started closed, Capture::Tiny will reclose
  them again when the capture block finishes.
  
  =head2 Scalar filehandles and STDIN, STDOUT or STDERR
  
  If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
  C<<< capture >>> or C<<< tee >>>, then Capture::Tiny will override the output handle for the
  duration of the C<<< capture >>> or C<<< tee >>> call and then send captured output to the
  output handle after the capture is complete.  (Requires Perl 5.8)
  
  Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
  reference.
  
  =head2 Tied STDIN, STDOUT or STDERR
  
  If STDOUT or STDERR are tied prior to the call to C<<< capture >>> or C<<< tee >>>, then
  Capture::Tiny will attempt to override the tie for the duration of the
  C<<< capture >>> or C<<< tee >>> call and then send captured output to the tied handle after
  the capture is complete.  (Requires Perl 5.8)
  
  Capture::Tiny does not (yet) support resending utf8 encoded data to a tied
  STDOUT or STDERR handle.  Characters will appear as bytes.
  
  Capture::Tiny attempts to preserve the semantics of tied STDIN, but capturing
  or teeing when STDIN is tied is currently broken on Windows.
  
  =head2 Modifiying STDIN, STDOUT or STDERR during a capture
  
  Attempting to modify STDIN, STDOUT or STDERR I<during> C<<< capture >>> or C<<< tee >>> is
  almost certainly going to cause problems.  Don't do that.
  
  =head2 No support for Perl 5.8.0
  
  It's just too buggy when it comes to layers and UTF8.
  
  =head1 ENVIRONMENT
  
  =head2 PERL_CAPTURE_TINY_TIMEOUT
  
  Capture::Tiny uses subprocesses for C<<< tee >>>.  By default, Capture::Tiny will
  timeout with an error if the subprocesses are not ready to receive data within
  30 seconds (or whatever is the value of C<<< $Capture::Tiny::TIMEOUT >>>).  An
  alternate timeout may be specified by setting the C<<< PERL_CAPTURE_TINY_TIMEOUT >>>
  environment variable.  Setting it to zero will disable timeouts.
  
  =head1 BUGS
  
  Please report any bugs or feature requests using the CPAN Request Tracker.
  Bugs can be submitted through the web interface at
  L<http://rt.cpan.org/Dist/Display.html?Queue=Capture-Tiny>
  
  When submitting a bug or request, please include a test-file or a patch to an
  existing test-file that illustrates the bug or desired feature.
  
  =head1 SEE ALSO
  
  This is a selection of CPAN modules that provide some sort of output capture,
  albeit with various limitations that make them appropriate only in particular
  circumstances.  I'm probably missing some.  The long list is provided to show
  why I felt Capture::Tiny was necessary.
  
  =over
  
  =item *
  
  L<IO::Capture>
  
  =item *
  
  L<IO::Capture::Extended>
  
  =item *
  
  L<IO::CaptureOutput>
  
  =item *
  
  L<IPC::Capture>
  
  =item *
  
  L<IPC::Cmd>
  
  =item *
  
  L<IPC::Open2>
  
  =item *
  
  L<IPC::Open3>
  
  =item *
  
  L<IPC::Open3::Simple>
  
  =item *
  
  L<IPC::Open3::Utils>
  
  =item *
  
  L<IPC::Run>
  
  =item *
  
  L<IPC::Run::SafeHandles>
  
  =item *
  
  L<IPC::Run::Simple>
  
  =item *
  
  L<IPC::Run3>
  
  =item *
  
  L<IPC::System::Simple>
  
  =item *
  
  L<Tee>
  
  =item *
  
  L<IO::Tee>
  
  =item *
  
  L<File::Tee>
  
  =item *
  
  L<Filter::Handle>
  
  =item *
  
  L<Tie::STDERR>
  
  =item *
  
  L<Tie::STDOUT>
  
  =item *
  
  L<Test::Output>
  
  =back
  
  =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
  
  =head1 SUPPORT
  
  =head2 Bugs / Feature Requests
  
  Please report any bugs or feature requests by email to C<bug-capture-tiny at rt.cpan.org>, or through
  the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Capture-Tiny>. You will be automatically notified of any
  progress on the request by the system.
  
  =head2 Source Code
  
  This is open source software.  The code repository is available for
  public review and contribution under the terms of the license.
  
  L<http://github.com/dagolden/capture-tiny/tree>
  
    git clone git://github.com/dagolden/capture-tiny.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2009 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
  
  
  __END__
  
  
CAPTURE_TINY

$fatpacked{"Class/C3.pm"} = <<'CLASS_C3';
  
  package Class::C3;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.23';
  
  our $C3_IN_CORE;
  our $C3_XS;
  
  BEGIN {
      if($] > 5.009_004) {
          $C3_IN_CORE = 1;
          require mro;
      }
      else {
          eval "require Class::C3::XS";
          my $error = $@;
          if(!$error) {
              $C3_XS = 1;
          }
          else {
              die $error if $error !~ /\blocate\b/;
              require Algorithm::C3;
              require Class::C3::next;
          }
      }
  }
  
  # this is our global stash of both
  # MRO's and method dispatch tables
  # the structure basically looks like
  # this:
  #
  #   $MRO{$class} = {
  #      MRO => [ <class precendence list> ],
  #      methods => {
  #          orig => <original location of method>,
  #          code => \&<ref to original method>
  #      },
  #      has_overload_fallback => (1 | 0)
  #   }
  #
  our %MRO;
  
  # use these for debugging ...
  sub _dump_MRO_table { %MRO }
  our $TURN_OFF_C3 = 0;
  
  # state tracking for initialize()/uninitialize()
  our $_initialized = 0;
  
  sub import {
      my $class = caller();
      # skip if the caller is main::
      # since that is clearly not relevant
      return if $class eq 'main';
  
      return if $TURN_OFF_C3;
      mro::set_mro($class, 'c3') if $C3_IN_CORE;
  
      # make a note to calculate $class
      # during INIT phase
      $MRO{$class} = undef unless exists $MRO{$class};
  }
  
  ## initializers
  
  # This prevents silly warnings when Class::C3 is
  #  used explicitly along with MRO::Compat under 5.9.5+
  
  { no warnings 'redefine';
  
  sub initialize {
      %next::METHOD_CACHE = ();
      # why bother if we don't have anything ...
      return unless keys %MRO;
      if($C3_IN_CORE) {
          mro::set_mro($_, 'c3') for keys %MRO;
      }
      else {
          if($_initialized) {
              uninitialize();
              $MRO{$_} = undef foreach keys %MRO;
          }
          _calculate_method_dispatch_tables();
          _apply_method_dispatch_tables();
          $_initialized = 1;
      }
  }
  
  sub uninitialize {
      # why bother if we don't have anything ...
      %next::METHOD_CACHE = ();
      return unless keys %MRO;
      if($C3_IN_CORE) {
          mro::set_mro($_, 'dfs') for keys %MRO;
      }
      else {
          _remove_method_dispatch_tables();
          $_initialized = 0;
      }
  }
  
  sub reinitialize { goto &initialize }
  
  } # end of "no warnings 'redefine'"
  
  ## functions for applying C3 to classes
  
  sub _calculate_method_dispatch_tables {
      return if $C3_IN_CORE;
      my %merge_cache;
      foreach my $class (keys %MRO) {
          _calculate_method_dispatch_table($class, \%merge_cache);
      }
  }
  
  sub _calculate_method_dispatch_table {
      return if $C3_IN_CORE;
      my ($class, $merge_cache) = @_;
      no strict 'refs';
      my @MRO = calculateMRO($class, $merge_cache);
      $MRO{$class} = { MRO => \@MRO };
      my $has_overload_fallback;
      my %methods;
      # NOTE:
      # we do @MRO[1 .. $#MRO] here because it
      # makes no sense to interogate the class
      # which you are calculating for.
      foreach my $local (@MRO[1 .. $#MRO]) {
          # if overload has tagged this module to
          # have use "fallback", then we want to
          # grab that value
          $has_overload_fallback = ${"${local}::()"}
              if !defined $has_overload_fallback && defined ${"${local}::()"};
          foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
              # skip if already overriden in local class
              next unless !defined *{"${class}::$method"}{CODE};
              $methods{$method} = {
                  orig => "${local}::$method",
                  code => \&{"${local}::$method"}
              } unless exists $methods{$method};
          }
      }
      # now stash them in our %MRO table
      $MRO{$class}->{methods} = \%methods;
      $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
  }
  
  sub _apply_method_dispatch_tables {
      return if $C3_IN_CORE;
      foreach my $class (keys %MRO) {
          _apply_method_dispatch_table($class);
      }
  }
  
  sub _apply_method_dispatch_table {
      return if $C3_IN_CORE;
      my $class = shift;
      no strict 'refs';
      ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
          if !defined &{"${class}::()"}
             && defined $MRO{$class}->{has_overload_fallback};
      foreach my $method (keys %{$MRO{$class}->{methods}}) {
          if ( $method =~ /^\(/ ) {
              my $orig = $MRO{$class}->{methods}->{$method}->{orig};
              ${"${class}::$method"} = $$orig if defined $$orig;
          }
          *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
      }
  }
  
  sub _remove_method_dispatch_tables {
      return if $C3_IN_CORE;
      foreach my $class (keys %MRO) {
          _remove_method_dispatch_table($class);
      }
  }
  
  sub _remove_method_dispatch_table {
      return if $C3_IN_CORE;
      my $class = shift;
      no strict 'refs';
      delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
      foreach my $method (keys %{$MRO{$class}->{methods}}) {
          delete ${"${class}::"}{$method}
              if defined *{"${class}::${method}"}{CODE} &&
                 (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
      }
  }
  
  sub calculateMRO {
      my ($class, $merge_cache) = @_;
  
      return Algorithm::C3::merge($class, sub {
          no strict 'refs';
          @{$_[0] . '::ISA'};
      }, $merge_cache);
  }
  
  # Method overrides to support 5.9.5+ or Class::C3::XS
  
  sub _core_calculateMRO { @{mro::get_linear_isa($_[0], 'c3')} }
  
  if($C3_IN_CORE) {
      no warnings 'redefine';
      *Class::C3::calculateMRO = \&_core_calculateMRO;
  }
  elsif($C3_XS) {
      no warnings 'redefine';
      *Class::C3::calculateMRO = \&Class::C3::XS::calculateMRO;
      *Class::C3::_calculate_method_dispatch_table
          = \&Class::C3::XS::_calculate_method_dispatch_table;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Class::C3 - A pragma to use the C3 method resolution order algortihm
  
  =head1 SYNOPSIS
  
      # NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead!
      package A;
      use Class::C3;
      sub hello { 'A::hello' }
  
      package B;
      use base 'A';
      use Class::C3;
  
      package C;
      use base 'A';
      use Class::C3;
  
      sub hello { 'C::hello' }
  
      package D;
      use base ('B', 'C');
      use Class::C3;
  
      # Classic Diamond MI pattern
      #    <A>
      #   /   \
      # <B>   <C>
      #   \   /
      #    <D>
  
      package main;
  
      # initializez the C3 module
      # (formerly called in INIT)
      Class::C3::initialize();
  
      print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
  
      print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
  
      D->can('hello')->();          # can() also works correctly
      UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
  
  =head1 DESCRIPTION
  
  This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right
  (a.k.a - pre-order) to the more sophisticated C3 method resolution order.
  
  B<NOTE:> YOU SHOULD NOT USE THIS MODULE DIRECTLY - The feature provided
  is integrated into perl version >= 5.9.5, and you should use L<MRO::Compat>
  instead, which will use the core implementation in newer perls, but fallback
  to using this implementation on older perls.
  
  =head2 What is C3?
  
  C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
  inheritance. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
  and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
  Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
  default MRO for Parrot objects as well.
  
  =head2 How does C3 work.
  
  C3 works by always preserving local precendence ordering. This essentially means that no class will
  appear before any of its subclasses. Take the classic diamond inheritance pattern for instance:
  
       <A>
      /   \
    <B>   <C>
      \   /
       <D>
  
  The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
  though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
  (D, B, C, A), which does not have this same issue.
  
  This example is fairly trival, for more complex examples and a deeper explaination, see the links in
  the L<SEE ALSO> section.
  
  =head2 How does this module work?
  
  This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is
  called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
  gathers information from the symbol tables of each of those classes, and builds a set of method
  aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
  then adds the method aliases into the local classes symbol table.
  
  The end result is actually classes with pre-cached method dispatch. However, this caching does not
  do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
  your classes to be effectively closed. See the L<CAVEATS> section for more details.
  
  =head1 OPTIONAL LOWERCASE PRAGMA
  
  This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
  the regular install since lowercase module names are considered I<"bad"> by some people. However I
  think that code looks much nicer like this:
  
    package MyClass;
    use c3;
  
  The the more clunky:
  
    package MyClass;
    use Class::C3;
  
  But hey, it's your choice, thats why it is optional.
  
  =head1 FUNCTIONS
  
  =over 4
  
  =item B<calculateMRO ($class)>
  
  Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
  
  =item B<initialize>
  
  This B<must be called> to initalize the C3 method dispatch tables, this module B<will not work> if
  you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
  use C3. Here is a quick code example:
  
    package Foo;
    use Class::C3;
    # ... Foo methods here
  
    package Bar;
    use Class::C3;
    use base 'Foo';
    # ... Bar methods here
  
    package main;
  
    Class::C3::initialize(); # now it is safe to use Foo and Bar
  
  This function used to be called automatically for you in the INIT phase of the perl compiler, but
  that lead to warnings if this module was required at runtime. After discussion with my user base
  (the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a
  convience. I apologize to anyone this causes problems for (although i would very suprised if I had
  any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define
  your own INIT method which calls this function.
  
  NOTE:
  
  If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
  clear the MRO cache first.
  
  =item B<uninitialize>
  
  Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
  style dispatch order (depth-first, left-to-right).
  
  =item B<reinitialize>
  
  This is an alias for L</initialize> above.
  
  =back
  
  =head1 METHOD REDISPATCHING
  
  It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
  module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
  method along the C3 linearization. This is best shown with an example.
  
    # a classic diamond MI pattern ...
    #    <A>
    #   /   \
    # <B>   <C>
    #   \   /
    #    <D>
  
    package A;
    use c3;
    sub foo { 'A::foo' }
  
    package B;
    use base 'A';
    use c3;
    sub foo { 'B::foo => ' . (shift)->next::method() }
  
    package C;
    use base 'A';
    use c3;
    sub foo { 'C::foo => ' . (shift)->next::method() }
  
    package D;
    use base ('B', 'C');
    use c3;
    sub foo { 'D::foo => ' . (shift)->next::method() }
  
    print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo"
  
  A few things to note. First, we do not require you to add on the method name to the C<next::method>
  call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
  that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
  
  The next thing to keep in mind is that you will need to pass all arguments to C<next::method>.  It can
  not automatically use the current C<@_>.
  
  If C<next::method> cannot find a next method to re-dispatch the call to, it will throw an exception.
  You can use C<next::can> to see if C<next::method> will succeed before you call it like so:
  
    $self->next::method(@_) if $self->next::can;
  
  Additionally, you can use C<maybe::next::method> as a shortcut to only call the next method if it exists.
  The previous example could be simply written as:
  
    $self->maybe::next::method(@_);
  
  There are some caveats about using C<next::method>, see below for those.
  
  =head1 CAVEATS
  
  This module used to be labeled as I<experimental>, however it has now been pretty heavily tested by
  the good folks over at L<DBIx::Class> and I am confident this module is perfectly usable for
  whatever your needs might be.
  
  But there are still caveats, so here goes ...
  
  =over 4
  
  =item Use of C<SUPER::>.
  
  The idea of C<SUPER::> under multiple inheritance is ambigious, and generally not recomended anyway.
  However, its use in conjuntion with this module is very much not recommended, and in fact very
  discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
  more details on its usage above.
  
  =item Changing C<@ISA>.
  
  It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
  do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
  module, and therefore probably won't even show up. If you do this, you will need to call C<reinitialize>
  in order to recalulate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
  in F<t/20_reinitialize.t> for more information.
  
  =item Adding/deleting methods from class symbol tables.
  
  This module calculates the MRO for each requested class by interogating the symbol tables of said classes.
  So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in
  the calculated MRO. Just as with changing the C<@ISA>, you will need to call C<reinitialize> for any
  changes you make to take effect.
  
  =item Calling C<next::method> from methods defined outside the class
  
  There is an edge case when using C<next::method> from within a subroutine which was created in a different
  module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which
  will not work correctly:
  
    *Foo::foo = sub { (shift)->next::method(@_) };
  
  The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up
  in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method>
  uses C<caller> to find the name of the method it was called in, it will fail in this case.
  
  But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and
  assign a name to an anonymous subroutine for you. Simply do this:
  
    use Sub::Name 'subname';
    *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
  
  and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't
  manage to find a workaround for it, so until someone gives me a working patch this will be a known
  limitation of this module.
  
  =back
  
  =head1 COMPATIBILITY
  
  If your software requires Perl 5.9.5 or higher, you do not need L<Class::C3>, you can simply C<use mro 'c3'>, and not worry about C<initialize()>, avoid some of the above caveats, and get the best possible performance.  See L<mro> for more details.
  
  If your software is meant to work on earlier Perls, use L<Class::C3> as documented here.  L<Class::C3> will detect Perl 5.9.5+ and take advantage of the core support when available.
  
  =head1 Class::C3::XS
  
  This module will load L<Class::C3::XS> if it's installed and you are running on a Perl version older than 5.9.5.  Installing this is recommended when possible, as it results in significant performance improvements (but unlike the 5.9.5+ core support, it still has all of the same caveats as L<Class::C3>).
  
  =head1 CODE COVERAGE
  
  L<Devel::Cover> was reporting 94.4% overall test coverage earlier in this module's life.  Currently, the test suite does things that break under coverage testing, but it is fair to assume the coverage is still close to that value.
  
  =head1 SEE ALSO
  
  =head2 The original Dylan paper
  
  =over 4
  
  =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
  
  =back
  
  =head2 The prototype Perl 6 Object Model uses C3
  
  =over 4
  
  =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
  
  =back
  
  =head2 Parrot now uses C3
  
  =over 4
  
  =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
  
  =item L<http://use.perl.org/~autrijus/journal/25768>
  
  =back
  
  =head2 Python 2.3 MRO related links
  
  =over 4
  
  =item L<http://www.python.org/2.3/mro.html>
  
  =item L<http://www.python.org/2.2.2/descrintro.html#mro>
  
  =back
  
  =head2 C3 for TinyCLOS
  
  =over 4
  
  =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
  
  =back
  
  =head1 ACKNOWLEGEMENTS
  
  =over 4
  
  =item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class>
  and finding many bugs and providing fixes.
  
  =item Thanks to Justin Guenther for making C<next::method> more robust by handling
  calls inside C<eval> and anon-subs.
  
  =item Thanks to Robert Norris for adding support for C<next::can> and
  C<maybe::next::method>.
  
  =back
  
  =head1 AUTHOR
  
  Stevan Little, E<lt>stevan@iinteractive.comE<gt>
  
  Brandon L. Black, E<lt>blblack@gmail.comE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2005, 2006 by Infinity Interactive, Inc.
  
  L<http://www.iinteractive.com>
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
CLASS_C3

$fatpacked{"Class/C3/next.pm"} = <<'CLASS_C3_NEXT';
  package  # hide me from PAUSE
      next;
  
  use strict;
  use warnings;
  no warnings 'redefine'; # for 00load.t w/ core support
  
  use Scalar::Util 'blessed';
  
  our $VERSION = '0.23';
  
  our %METHOD_CACHE;
  
  sub method {
      my $self     = $_[0];
      my $class    = blessed($self) || $self;
      my $indirect = caller() =~ /^(?:next|maybe::next)$/;
      my $level = $indirect ? 2 : 1;
  
      my ($method_caller, $label, @label);
      while ($method_caller = (caller($level++))[3]) {
        @label = (split '::', $method_caller);
        $label = pop @label;
        last unless
          $label eq '(eval)' ||
          $label eq '__ANON__';
      }
  
      my $method;
  
      my $caller   = join '::' => @label;
  
      $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
  
          my @MRO = Class::C3::calculateMRO($class);
  
          my $current;
          while ($current = shift @MRO) {
              last if $caller eq $current;
          }
  
          no strict 'refs';
          my $found;
          foreach my $class (@MRO) {
              next if (defined $Class::C3::MRO{$class} &&
                       defined $Class::C3::MRO{$class}{methods}{$label});
              last if (defined ($found = *{$class . '::' . $label}{CODE}));
          }
  
          $found;
      };
  
      return $method if $indirect;
  
      die "No next::method '$label' found for $self" if !$method;
  
      goto &{$method};
  }
  
  sub can { method($_[0]) }
  
  package  # hide me from PAUSE
      maybe::next;
  
  use strict;
  use warnings;
  no warnings 'redefine'; # for 00load.t w/ core support
  
  our $VERSION = '0.02';
  
  sub method { (next::method($_[0]) || return)->(@_) }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Class::C3::next - Pure-perl next::method and friends
  
  =head1 DESCRIPTION
  
  This module is used internally by L<Class::C3> when
  neccesary, and shouldn't be used (or required in
  distribution dependencies) directly.  It
  defines C<next::method>, C<next::can>, and
  C<maybe::next::method> in pure perl.
  
  =head1 AUTHOR
  
  Stevan Little, E<lt>stevan@iinteractive.comE<gt>
  
  Brandon L. Black, E<lt>blblack@gmail.comE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2005, 2006 by Infinity Interactive, Inc.
  
  L<http://www.iinteractive.com>
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
CLASS_C3_NEXT

$fatpacked{"Data/Dumper/Concise.pm"} = <<'DATA_DUMPER_CONCISE';
  package Data::Dumper::Concise;
  
  use 5.006;
  
  $VERSION = '2.020';
  
  require Exporter;
  require Data::Dumper;
  
  BEGIN { @ISA = qw(Exporter) }
  
  @EXPORT = qw(Dumper DumperF DumperObject);
  
  sub DumperObject {
    my $dd = Data::Dumper->new([]);
    $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
  }
  
  sub Dumper { DumperObject->Values([ @_ ])->Dump }
  
  sub DumperF (&@) {
    my $code = shift;
    return $code->(map Dumper($_), @_);
  }
  
  =head1 NAME
  
  Data::Dumper::Concise - Less indentation and newlines plus sub deparsing
  
  =head1 SYNOPSIS
  
    use Data::Dumper::Concise;
  
    warn Dumper($var);
  
  is equivalent to:
  
    use Data::Dumper;
    {
      local $Data::Dumper::Terse = 1;
      local $Data::Dumper::Indent = 1;
      local $Data::Dumper::Useqq = 1;
      local $Data::Dumper::Deparse = 1;
      local $Data::Dumper::Quotekeys = 0;
      local $Data::Dumper::Sortkeys = 1;
      warn Dumper($var);
    }
  
  So for the structure:
  
    { foo => "bar\nbaz", quux => sub { "fleem" } };
  
  Data::Dumper::Concise will give you:
  
    {
      foo => "bar\nbaz",
      quux => sub {
          use warnings;
          use strict 'refs';
          'fleem';
      }
    }
  
  instead of the default Data::Dumper output:
  
    $VAR1 = {
     'quux' => sub { "DUMMY" },
     'foo' => 'bar
    baz'
    };
  
  (note the tab indentation, oh joy ...)
  
  If you need to get the underlying L<Dumper> object just call C<DumperObject>.
  
  Also try out C<DumperF> which takes a C<CodeRef> as the first argument to
  format the output.  For example:
  
    use Data::Dumper::Concise;
  
    warn DumperF { "result: $_[0] result2: $_[1]" } $foo, $bar;
  
  Which is the same as:
  
    warn 'result: ' . Dumper($foo) . ' result2: ' . Dumper($bar);
  
  =head1 DESCRIPTION
  
  This module always exports a single function, Dumper, which can be called
  with an array of values to dump those values.
  
  It exists, fundamentally, as a convenient way to reproduce a set of Dumper
  options that we've found ourselves using across large numbers of applications,
  primarily for debugging output.
  
  The principle guiding theme is "all the concision you can get while still
  having a useful dump and not doing anything cleverer than setting Data::Dumper
  options" - it's been pointed out to us that Data::Dump::Streamer can produce
  shorter output with less lines of code. We know. This is simpler and we've
  never seen it segfault. But for complex/weird structures, it generally rocks.
  You should use it as well, when Concise is underkill. We do.
  
  Why is deparsing on when the aim is concision? Because you often want to know
  what subroutine refs you have when debugging and because if you were planning
  to eval this back in you probably wanted to remove subrefs first and add them
  back in a custom way anyway. Note that this -does- force using the pure perl
  Dumper rather than the XS one, but I've never in my life seen Data::Dumper
  show up in a profile so "who cares?".
  
  =head1 BUT BUT BUT ...
  
  Yes, we know. Consider this module in the ::Tiny spirit and feel free to
  write a Data::Dumper::Concise::ButWithExtraTwiddlyBits if it makes you
  happy. Then tell us so we can add it to the see also section.
  
  =head1 SUGARY SYNTAX
  
  This package also provides:
  
  L<Data::Dumper::Concise::Sugar> - provides Dwarn and DwarnS convenience functions
  
  L<Devel::Dwarn> - shorter form for Data::Dumper::Concise::Sugar
  
  =head1 SEE ALSO
  
  We use for some purposes, and dearly love, the following alternatives:
  
  L<Data::Dump> - prettiness oriented but not amazingly configurable
  
  L<Data::Dump::Streamer> - brilliant. beautiful. insane. extensive. excessive. try it.
  
  L<JSON::XS> - no, really. If it's just plain data, JSON is a great option.
  
  =head1 AUTHOR
  
  mst - Matt S. Trout <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010 the Data::Dumper::Concise L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
  
  1;
DATA_DUMPER_CONCISE

$fatpacked{"Data/Dumper/Concise/Sugar.pm"} = <<'DATA_DUMPER_CONCISE_SUGAR';
  package Data::Dumper::Concise::Sugar;
  
  use 5.006;
  
  use Exporter ();
  use Data::Dumper::Concise ();
  
  BEGIN { @ISA = qw(Exporter) }
  
  @EXPORT = qw(
     $Dwarn $DwarnN Dwarn DwarnS DwarnL DwarnN DwarnF
     $Ddie $DdieN Ddie DdieS DdieL DdieN DdieD
  );
  
  sub Dwarn { return DwarnL(@_) if wantarray; DwarnS($_[0]) }
  
  our $Dwarn = \&Dwarn;
  our $DwarnN = \&DwarnN;
  
  sub DwarnL { warn Data::Dumper::Concise::Dumper @_; @_ }
  
  sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
  
  sub DwarnN ($) {
     require Devel::ArgNames;
     my $x = Devel::ArgNames::arg_names();
     warn(($x?$x:'(anon)') . ' => ' . Data::Dumper::Concise::Dumper $_[0]); $_[0]
  }
  
  sub DwarnF (&@) { my $c = shift; warn &Data::Dumper::Concise::DumperF($c, @_); @_ }
  
  sub Ddie { DdieL(@_) if wantarray; DdieS($_[0]) }
  
  our $Ddie = \&Ddie;
  our $DdieN = \&DdieN;
  
  sub DdieL { die Data::Dumper::Concise::Dumper @_ }
  
  sub DdieS ($) { die Data::Dumper::Concise::Dumper $_[0] }
  
  sub DdieN ($) {
     require Devel::ArgNames;
     my $x = Devel::ArgNames::arg_names();
     die(($x?$x:'(anon)') . ' => ' . Data::Dumper::Concise::Dumper $_[0]);
  }
  
  =head1 NAME
  
  Data::Dumper::Concise::Sugar - return Dwarn @return_value
  
  =head1 SYNOPSIS
  
    use Data::Dumper::Concise::Sugar;
  
    return Dwarn some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    if (wantarray) {
       my @return = some_call(...);
       warn Dumper(@return);
       return @return;
    } else {
       my $return = some_call(...);
       warn Dumper($return);
       return $return;
    }
  
  but shorter. If you need to force scalar context on the value,
  
    use Data::Dumper::Concise::Sugar;
  
    return DwarnS some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my $return = some_call(...);
    warn Dumper($return);
    return $return;
  
  If you need to force list context on the value,
  
    use Data::Dumper::Concise::Sugar;
  
    return DwarnL some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my @return = some_call(...);
    warn Dumper(@return);
    return @return;
  
  If you want to label your output, try DwarnN
  
    use Data::Dumper::Concise::Sugar;
  
    return DwarnN $foo
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my @return = some_call(...);
    warn '$foo => ' . Dumper(@return);
    return @return;
  
  If you want to output a reference returned by a method easily, try $Dwarn
  
   $foo->bar->{baz}->$Dwarn
  
  is equivalent to:
  
    my $return = $foo->bar->{baz};
    warn Dumper($return);
    return $return;
  
  If you want to format the output of your data structures, try DwarnF
  
   my ($a, $c) = DwarnF { "awesome: $_[0] not awesome: $_[1]" } $awesome, $cheesy;
  
  is equivalent to:
  
    my @return = ($awesome, $cheesy);
    warn DumperF { "awesome: $_[0] not awesome: $_[1]" } $awesome, $cheesy;
    return @return;
  
  If you want to immediately die after outputting the data structure, every
  Dwarn subroutine has a paired Ddie version, so just replace the warn with die.
  For example:
  
   DdieL 'foo', { bar => 'baz' };
  
  =head1 DESCRIPTION
  
    use Data::Dumper::Concise::Sugar;
  
  will import Dwarn, $Dwarn, DwarnL, DwarnN, and DwarnS into your namespace. Using
  L<Exporter>, so see its docs for ways to make it do something else.
  
  =head2 Dwarn
  
    sub Dwarn { return DwarnL(@_) if wantarray; DwarnS($_[0]) }
  
  =head2 $Dwarn
  
    $Dwarn = \&Dwarn
  
  =head2 $DwarnN
  
    $DwarnN = \&DwarnN
  
  =head2 DwarnL
  
    sub Dwarn { warn Data::Dumper::Concise::Dumper @_; @_ }
  
  =head2 DwarnS
  
    sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
  
  =head2 DwarnN
  
    sub DwarnN { warn '$argname => ' . Data::Dumper::Concise::Dumper $_[0]; $_[0] }
  
  B<Note>: this requires L<Devel::ArgNames> to be installed.
  
  =head2 DwarnF
  
    sub DwarnF (&@) { my $c = shift; warn &Data::Dumper::Concise::DumperF($c, @_); @_ }
  
  =head1 TIPS AND TRICKS
  
  =head2 global usage
  
  Instead of always just doing:
  
    use Data::Dumper::Concise::Sugar;
  
    Dwarn ...
  
  We tend to do:
  
    perl -MData::Dumper::Concise::Sugar foo.pl
  
  (and then in the perl code:)
  
    ::Dwarn ...
  
  That way, if you leave them in and run without the
  C<< use Data::Dumper::Concise::Sugar >> the program will fail to compile and
  you are less likely to check it in by accident.  Furthmore it allows that
  much less friction to add debug messages.
  
  =head2 method chaining
  
  One trick which is useful when doing method chaining is the following:
  
    my $foo = Bar->new;
    $foo->bar->baz->Data::Dumper::Concise::Sugar::DwarnS->biff;
  
  which is the same as:
  
    my $foo = Bar->new;
    (DwarnS $foo->bar->baz)->biff;
  
  =head1 SEE ALSO
  
  You probably want L<Devel::Dwarn>, it's the shorter name for this module.
  
  =cut
  
  1;
DATA_DUMPER_CONCISE_SUGAR

$fatpacked{"Devel/Dwarn.pm"} = <<'DEVEL_DWARN';
  package Devel::Dwarn;
  
  use Data::Dumper::Concise::Sugar;
  
  sub import {
    Data::Dumper::Concise::Sugar->export_to_level(1, @_);
  }
  
  =head1 NAME
  
  Devel::Dwarn - return Dwarn @return_value
  
  =head1 SYNOPSIS
  
    use Devel::Dwarn;
  
    return Dwarn some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    if (wantarray) {
       my @return = some_call(...);
       warn Dumper(@return);
       return @return;
    } else {
       my $return = some_call(...);
       warn Dumper($return);
       return $return;
    }
  
  but shorter. If you need to force scalar context on the value,
  
    use Devel::Dwarn;
  
    return DwarnS some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my $return = some_call(...);
    warn Dumper($return);
    return $return;
  
  If you need to force list context on the value,
  
    use Devel::Dwarn;
  
    return DwarnL some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my @return = some_call(...);
    warn Dumper(@return);
    return @return;
  
  If you want to label your output, try DwarnN
  
    use Devel::Dwarn;
  
    return DwarnN $foo
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my @return = some_call(...);
    warn '$foo => ' . Dumper(@return);
    return @return;
  
  If you want to output a reference returned by a method easily, try $Dwarn
  
   $foo->bar->{baz}->$Dwarn
  
  is equivalent to:
  
    my $return = $foo->bar->{baz};
    warn Dumper($return);
    return $return;
  
  If you want to immediately die after outputting the data structure, every
  Dwarn subroutine has a paired Ddie version, so just replace the warn with die.
  For example:
  
   DdieL 'foo', { bar => 'baz' };
  
  =head1 TIPS AND TRICKS
  
  =head2 global usage
  
  Instead of always just doing:
  
    use Devel::Dwarn;
  
    Dwarn ...
  
  We tend to do:
  
    perl -MDevel::Dwarn foo.pl
  
  (and then in the perl code:)
  
    ::Dwarn ...
  
  That way, if you leave them in and run without the C<< use Devel::Dwarn >>
  the program will fail to compile and you are less likely to check it in by
  accident.  Furthmore it allows that much less friction to add debug messages.
  
  =head2 method chaining
  
  One trick which is useful when doing method chaining is the following:
  
    my $foo = Bar->new;
    $foo->bar->baz->Devel::Dwarn::DwarnS->biff;
  
  which is the same as:
  
    my $foo = Bar->new;
    (DwarnS $foo->bar->baz)->biff;
  
  =head1 SEE ALSO
  
  This module is really just a shortcut for L<Data::Dumper::Concise::Sugar>, check
  it out for more complete documentation.
  
  =cut
  
  1;
DEVEL_DWARN

$fatpacked{"Exporter/Declare.pm"} = <<'EXPORTER_DECLARE';
  package Exporter::Declare;
  use strict;
  use warnings;
  
  use Carp qw/croak/;
  use Scalar::Util qw/reftype/;
  use aliased 'Exporter::Declare::Meta';
  use aliased 'Exporter::Declare::Specs';
  use aliased 'Exporter::Declare::Export::Sub';
  use aliased 'Exporter::Declare::Export::Variable';
  use aliased 'Exporter::Declare::Export::Generator';
  
  BEGIN { Meta->new( __PACKAGE__ )}
  
  our $VERSION = '0.105';
  our @CARP_NOT = qw/
      Exporter::Declare
      Exporter::Declare::Specs
      Exporter::Declare::Meta
      Exporter::Declare::Magic
  /;
  
  default_exports( qw/
      import
      exports
      default_exports
      import_options
      import_arguments
      export_tag
      export
      gen_export
      default_export
      gen_default_export
  /);
  
  exports( qw/
      reexport
      export_to
  /);
  
  export_tag( magic => qw/
      !export
      !gen_export
      !default_export
      !gen_default_export
  /);
  
  sub import {
      my $class = shift;
      my $caller = caller;
  
      $class->alter_import_args( $caller, \@_ )
          if $class->can( 'alter_import_args' );
  
      my $specs = _parse_specs( $class, @_ );
  
      $class->before_import( $caller, $specs )
          if $class->can( 'before_import' );
  
      $specs->export( $caller );
  
      $class->after_import( $caller, $specs )
          if $class->can( 'after_import' );
  }
  
  sub after_import {
      my $class = shift;
      my ( $caller, $specs ) = @_;
      Meta->new( $caller );
  
      return unless my $args = $specs->config->{ 'magic' };
      $args = ['-default'] unless ref $args && ref $args eq 'ARRAY';
  
      require Exporter::Declare::Magic;
      export_to( 'Exporter::Declare::Magic', $caller, @$args );
  }
  
  sub _parse_specs {
      my $class = _find_export_class( \@_ );
      my ( @args ) = @_;
  
      # XXX This is ugly!
      unshift @args => '-default'
          if $class eq __PACKAGE__
          && grep { $_ eq '-magic' } @args;
  
      return Specs->new( $class, @args );
  }
  
  sub export_to {
      my $class = _find_export_class( \@_ );
      my ( $dest, @args ) = @_;
      my $specs = _parse_specs( $class, @args );
      $specs->export( $dest );
      return $specs;
  }
  
  sub export_tag {
      my $class = _find_export_class( \@_ );
      my ( $tag, @list ) = @_;
      $class->export_meta->export_tags_push( $tag, @list );
  }
  
  sub exports {
      my $class = _find_export_class( \@_ );
      my $meta = $class->export_meta;
      _export( $class, undef, $_ ) for @_;
      $meta->export_tags_get('all');
  }
  
  sub default_exports {
      my $class = _find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->export_tags_push( 'default', _export( $class, undef, $_ ))
          for @_;
      $meta->export_tags_get('default');
  }
  
  sub export {
      my $class = _find_export_class( \@_ );
      _export( $class, undef, @_ );
  }
  
  sub gen_export {
      my $class = _find_export_class( \@_ );
      _export( $class, Generator(), @_ );
  }
  
  sub default_export {
      my $class = _find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->export_tags_push( 'default', _export( $class, undef, @_ ));
  }
  
  sub gen_default_export {
      my $class = _find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->export_tags_push( 'default', _export( $class, Generator(), @_ ));
  }
  
  sub import_options {
      my $class = _find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->options_add($_) for @_;
  }
  
  sub import_arguments {
      my $class = _find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->arguments_add($_) for @_;
  }
  
  sub _parse_export_params {
      my ( $class, $expclass, $name, @param ) = @_;
      my $ref = ref($param[-1]) ? pop(@param) : undef;
      my $meta = $class->export_meta;
  
      ( $ref, $name ) = $meta->get_ref_from_package( $name )
          unless $ref;
  
      ( my $type, $name ) = ($name =~ m/^([\$\@\&\%]?)(.*)$/);
      $type = "" if $type eq '&';
  
      my $fullname = "$type$name";
  
      return (
          class => $class,
          export_class => $expclass || undef,
          name => $name,
          ref => $ref,
          type => $type || "",
          fullname => $fullname,
          args => \@param,
      );
  }
  
  sub _export {
      _add_export( _parse_export_params( @_ ));
  }
  
  sub _add_export {
      my %params = @_;
      my $meta = $params{class}->export_meta;
      $params{ export_class } ||= reftype( $params{ref} ) eq 'CODE'
          ? Sub()
          : Variable();
  
      $params{ export_class }->new(
          $params{ ref },
          exported_by => $params{ class },
          ($params{ type } ? ( type   => 'variable' )
                           : ( type   => 'sub'      )),
          ($params{ extra_exporter_props }
              ? %{ $params{ extra_exporter_props }}
              : ()
          ),
      );
  
      $meta->exports_add( $params{fullname}, $params{ref} );
  
      return $params{fullname};
  }
  
  sub _find_export_class {
      my $args = shift;
  
      return shift( @$args )
          if @$args
          && eval { $args->[0]->can('export_meta') };
  
      return caller(1);
  }
  
  sub reexport {
      my $from = pop;
      my $class = shift || caller;
      $class->export_meta->reexport( $from );
  }
  
  1;
  
  =head1 NAME
  
  Exporter::Declare - Exporting done right
  
  =head1 DESCRIPTION
  
  Exporter::Declare is a meta-driven exporting tool. Exporter::Declare tries to
  adopt all the good features of other exporting tools, while throwing away
  horrible interfaces. Exporter::Declare also provides hooks that allow you to add
  options and arguments for import. Finally, Exporter::Declare's meta-driven
  system allows for top-notch introspection.
  
  =head1 FEATURES
  
  =over 4
  
  =item Declarative exporting (like L<Moose> for exporting)
  
  =item Meta-driven for introspection
  
  =item Customizable import() method
  
  =item Export groups (tags)
  
  =item Export generators for subs and variables
  
  =item Clear and concise OO API
  
  =item Exports are blessed, allowing for more introspection
  
  =item Import syntax based off of L<Sub::Exporter>
  
  =item Packages export aliases
  
  =back
  
  =head1 SYNOPSIS
  
  =head2 EXPORTER
  
      package Some::Exporter;
      use Exporter::Declare;
  
      default_exports qw/ do_the_thing /;
      exports qw/ subA subB $SCALAR @ARRAY %HASH /;
  
      # Create a couple tags (import lists)
      export_tag subs => qw/ subA subB do_the_thing /;
      export_tag vars => qw/ $SCALAR @ARRAY %HASH /;
  
      # These are simple boolean options, pass '-optionA' to enable it.
      import_options   qw/ optionA optionB /;
  
      # These are options which slurp in the next argument as their value, pass
      # '-optionC' => 'foo' to give it a value.
      import_arguments qw/ optionC optionD /;
  
      export anon_export => sub { ... };
      export '@anon_var' => [...];
  
      default_export a_default => sub { 'default!' }
  
      our $X = "x";
      default_export '$X';
  
      my $iterator = 'a';
      gen_export unique_class_id => sub {
          my $current = $iterator++;
          return sub { $current };
      };
  
      gen_default_export '$my_letter' => sub {
          my $letter = $iterator++;
          return \$letter;
      };
  
      # You can create a function to mangle the arguments before they are
      # parsed into a Exporter::Declare::Spec object.
      sub alter_import_args {
         my ($class, $args) = @_;
  
         # fiddle with args before importing routines are called
         @$args = grep { !/^skip_/ } @$args
      }
  
      # There is no need to fiddle with import() or do any wrapping.
      # the $specs data structure means you generally do not need to parse
      # arguments yourself (but you can if you want using alter_import_args())
  
      # Change the spec object before export occurs
      sub before_import {
          my $class = shift;
          my ( $importer, $specs ) = @_;
  
          if ($specs->config->{optionA}) {
              # Modify $spec attributes accordingly
          }
      }
  
      # Use spec object after export occurs
      sub after_import {
          my $class = shift;
          my ( $importer, $specs ) = @_;
  
          do_option_a() if $specs->config->{optionA};
  
          do_option_c( $specs->config->{optionC} )
              if $specs->config->{optionC};
  
          print "-subs tag was used\n"
              if $specs->config->{subs};
  
          print "exported 'subA'\n"
              if $specs->exports->{subA};
      }
  
      ...
  
  =head2 IMPORTER
  
      package Some::Importer;
      use Some::Exporter qw/ subA $SCALAR !%HASH /,
                          -default => { -prefix => 'my_' },
                          qw/ -optionA !-optionB /,
                          subB => { -as => 'sub_b' };
  
      subA();
      print $SCALAR;
      sub_b();
      my_do_the_thing();
  
      ...
  
  =head1 IMPORT INTERFACE
  
  Importing from a package that uses Exporter::Declare will be familiar to anyone
  who has imported from modules before. Arguments are all assumed to be export
  names, unless prefixed with C<-> or C<:> In which case they may be a tag or an
  option. Exports without a sigil are assumed to be code exports, variable
  exports must be listed with their sigil.
  
  Items prefixed with the C<!> symbol are forcfully excluded, regardless of any
  listed item that may normally include them. Tags can also be excluded, this
  will effectively exclude everything in the tag.
  
  Tags are simply lists of exports, the exporting class may define any number of
  tags. Exporter::Declare also has the concept of options, they have the same
  syntax as tags. Options may be boolean or argument based. Boolean options are
  actually 3 value, undef, false C<!>, or true. Argument based options will grab
  the next value in the arguments list as their own, regardless of what type of
  value it is.
  
  When you use the module, or call import(), all the arguments are transformed
  into an L<Exporter::Declare::Specs> object. Arguments are parsed for you into a
  list of imports, and a configuration hash in which tags/options are keys. Tags
  are listed in the config hash as true, false, or undef depending on if they
  were included, negated, or unlisted. Boolean options will be treated in the
  same way as tags. Options that take arguments will have the argument as their
  value.
  
  =head2 SELECTING ITEMS TO IMPORT
  
  Exports can be subs, or package variables (scalar, hash, array). For subs
  simply ask for the sub by name, you may optionally prefix the subs name with
  the sub sigil C<&>. For variables list the variable name along with its sigil
  C<$, %, or @>.
  
      use Some::Exporter qw/ somesub $somescalar %somehash @somearray /;
  
  =head2 TAGS
  
  Every exporter automatically has the following 3 tags, in addition they may
  define any number of custom tags. Tags can be specified by their name prefixed
  by either C<-> or C<:>.
  
  =over 4
  
  =item -all
  
  This tag may be used to import everything the exporter provides.
  
  =item -default
  
  This tag is used to import the default items exported. This will be used when
  no argument is provided to import.
  
  =item -alias
  
  Every package has an alias that it can export. This is the last segmant of the
  packages namespace. IE C<My::Long::Package::Name::Foo> could export the C<Foo()>
  function. These alias functionis simply return the full package name as a
  string, in this case C<'My::Long::Package::Name::Foo'>. This is similar to
  L<aliased>.
  
  The -alias tag is a shortcut so that you do not need to think about what the
  alias name would be when adding it to the import arguments.
  
      use My::Long::Package::Name::Foo -alias;
  
      my $foo = Foo()->new(...);
  
  =back
  
  =head2 RENAMING IMPORTED ITEMS
  
  You can prefix, suffix, or completely rename the items you import. Whenever an
  item is followed by a hash in the import list, that hash will be used for
  configuration. Configuration items always start with a dash C<->.
  
  The 3 available configuration options that effect import names are C<-prefix>,
  C<-suffix>, and C<-as>. If C<-as> is seen it will be used as is. If prefix or
  suffix are seen they will be attached to the original name (unless -as is
  present in which case they are ignored).
  
      use Some::Exporter subA => { -as => 'DoThing' },
                         subB => { -prefix => 'my_', -suffix => '_ok' };
  
  The example above will import C<subA()> under the name C<DoThing()>. It will
  also import C<subB()> under the name C<my_subB_ok()>.
  
  You may als specify a prefix and/or suffix for tags. The following example will
  import all the default exports with 'my_' prefixed to each name.
  
      use Some::Exporter -default => { -prefix => 'my_' };
  
  =head2 OPTIONS
  
  Some exporters will recognise options. Options look just like tags, and are
  specified the same way. What options do, and how they effect things is
  exporter-dependant.
  
      use Some::Exporter qw/ -optionA -optionB /;
  
  =head2 ARGUMENTS
  
  Some options require an argument. These options are just like other
  tags/options except that the next item in the argument list is slurped in as
  the option value.
  
      use Some::Exporter -ArgOption    => 'Value, not an export',
                         -ArgTakesHash => { ... };
  
  Once again available options are exporter specific.
  
  =head2 PROVIDING ARGUMENTS FOR GENERATED ITEMS
  
  Some items are generated at import time. These items may accept arguments.
  There are 3 ways to provide arguments, and they may all be mixed (though that
  is not recommended).
  
  As a hash
  
      use Some::Exporter generated => { key => 'val', ... };
  
  As an array
  
      use Some::Exporter generated => [ 'Arg1', 'Arg2', ... ];
  
  As an array in a config hash
  
      use Some::Exporter generated => { -as => 'my_gen', -args => [ 'arg1', ... ]};
  
  You can use all three at once, but this is really a bad idea, documented for completeness:
  
      use Some::Exporter generated => { -as => 'my_gen, key => 'value', -args => [ 'arg1', 'arg2' ]}
                         generated => [ 'arg3', 'arg4' ];
  
  The example above will work fine, all the arguments will make it into the
  generator. The only valid reason for this to work is that you may provide
  arguments such as C<-prefix> to a tag that brings in generator(), while also
  desiring to give arguments to generator() independantly.
  
  =head1 PRIMARY EXPORT API
  
  With the exception of import(), all the following work equally well as
  functions or class methods.
  
  =over 4
  
  =item import( @args )
  
  The import() class method. This turns the @args list into an
  L<Exporter::Declare::Specs> object.
  
  =item exports( @add_items )
  
  Add items to be exported.
  
  =item @list = exports()
  
  Retrieve list of exports.
  
  =item default_exports( @add_items )
  
  Add items to be exported, and add them to the -default tag.
  
  =item @list = default_exports()
  
  List of exports in the -default tag
  
  =item import_options(@add_items)
  
  Specify boolean options that should be accepted at import time.
  
  =item import_arguments(@add_items)
  
  Specify options that should be accepted at import that take arguments.
  
  =item export_tag( $name, @add_items );
  
  Define an export tag, or add items to an existing tag.
  
  =back
  
  =head1 EXTENDED EXPORT API
  
  These all work fine in function or method form, however the syntax sugar will
  only work in function form.
  
  =over 4
  
  =item reexport( $package )
  
  Make this exporter inherit all the exports and tags of $package. Works for
  Exporter::Declare or Exporter.pm based exporters. Re-Exporting of
  L<Sub::Exporter> based classes is not currently supported.
  
  =item export_to( $package, @args )
  
  Export to the specified class.
  
  =item export( $name )
  
  =item export( $name, $ref )
  
  export is a keyword that lets you export any 1 item at a time. The item can be
  exported by name, or name + ref. When a ref is provided, the export is created,
  but there is no corresponding variable/sub in the packages namespace.
  
  =item default_export( $name )
  
  =item default_export( $name, $ref )
  
  =item gen_export( $name )
  
  =item gen_export( $name, $ref )
  
  =item gen_default_export( $name )
  
  =item gen_default_export( $name, $ref )
  
  These all act just like export(), except that they add subrefs as generators,
  and/or add exports to the -default tag.
  
  =back
  
  =head1 MAGIC
  
      use Exporter::Declare '-magic';
  
  This adds L<Devel::Declare> magic to several functions. It also allows you to
  easily create or use parsers on your own exports. See
  L<Exporter::Declare::Magic> for more details.
  
  You can also provide import arguments to L<Devel::Declare::Magic>
  
      # Arguments to -magic must be in an arrayref, not a hashref.
      use Exporter::Declare -magic => [ '-default', '!export', -prefix => 'magic_' ];
  
  =head1 INTERNAL API
  
  Exporter/Declare.pm does not have much logic to speak of. Rather
  Exporter::Declare is sugar on top of class meta data stored in
  L<Exporter::Declare::Meta> objects. Arguments are parsed via
  L<Exporter::Declare::Specs>, and also turned into objects. Even exports are
  blessed references to the exported item itself, and handle the injection on
  their own (See L<Exporter::Declare::Export>).
  
  =head1 META CLASS
  
  All exporters have a meta class, the only way to get the meta object is to call
  the exporter_meta() method on the class/object that is an exporter. Any class
  that uses Exporter::Declare gets this method, and a meta-object.
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE

$fatpacked{"Exporter/Declare/Export.pm"} = <<'EXPORTER_DECLARE_EXPORT';
  package Exporter::Declare::Export;
  use strict;
  use warnings;
  use Carp qw/croak carp/;
  use Scalar::Util qw/reftype/;
  
  our %OBJECT_DATA;
  
  sub required_specs {qw/ exported_by /}
  
  sub new {
      my $class = shift;
      my ( $item, %specs ) = @_;
      my $self = bless( $item, $class );
  
      for my $prop ( $self->required_specs ) {
          croak "You must specify $prop when calling $class\->new()"
              unless $specs{$prop};
      }
  
      $OBJECT_DATA{$self} = \%specs;
  
      return $self;
  }
  
  sub _data {
      my $self = shift;
      ($OBJECT_DATA{$self}) = @_ if @_;
      $OBJECT_DATA{$self};
  }
  
  sub exported_by {
      shift->_data->{ exported_by };
  }
  
  sub inject {
      my $self = shift;
      my ( $class, $name, @args ) = @_;
  
      carp(
          "Ignoring arguments importing ("
          . reftype($self)
          . ")$name into $class: "
          . join( ', ', @args )
      ) if (@args);
  
      croak "You must provide a class and name to inject()"
          unless $class && $name;
      no strict 'refs';
      no warnings 'once';
      *{"$class\::$name"} = $self;
  }
  
  sub DESTROY {
      my $self = shift;
      delete $OBJECT_DATA{$self};
  }
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Export - Base class for all export objects.
  
  =head1 DESCRIPTION
  
  All exports are refs, and all are blessed. This class tracks some per-export
  information via an inside-out objects system. All things an export may need to
  do, such as inject itself into a package are handled here. This allows some
  complicated, or ugly logic to be abstracted out of the exporter and metadata
  classes.
  
  =head1 METHODS
  
  =over
  
  =item $class->new( $ref, exported_by => $package, %data )
  
  Create a new export from $ref. You must specify the name of the class doing the
  exporting.
  
  =item $export->inject( $package, $name, @args )
  
  This will inject the export into $package under $name. @args are ignored in
  most cases. See L<Exporter::Declare::Export::Generator> for an example where
  they are used.
  
  =item $package = $export->exported_by()
  
  Returns the name of the package from which this export was originally exported.
  
  =item @params = $export->required_specs()
  
  Documented for subclassing purposes. This should always return a list of
  required parameters at construction time.
  
  =item $export->DESTROY()
  
  Documented for subclassing purposes. This takes care of cleanup related to
  storing data in an inside-out objects system.
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_EXPORT

$fatpacked{"Exporter/Declare/Export/Alias.pm"} = <<'EXPORTER_DECLARE_EXPORT_ALIAS';
  package Exporter::Declare::Export::Alias;
  use strict;
  use warnings;
  
  use base 'Exporter::Declare::Export';
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Export::Alias - Export class for aliases.
  
  =head1 DESCRIPTION
  
  Export class for aliases. Currently does not expand upon
  L<Exporter::Declare::Export> in any way.
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_EXPORT_ALIAS

$fatpacked{"Exporter/Declare/Export/Generator.pm"} = <<'EXPORTER_DECLARE_EXPORT_GENERATOR';
  package Exporter::Declare::Export::Generator;
  use strict;
  use warnings;
  
  use base 'Exporter::Declare::Export::Sub';
  use Exporter::Declare::Export::Variable;
  use Carp qw/croak/;
  
  sub required_specs {
      my $self = shift;
      return(
          $self->SUPER::required_specs(),
          qw/ type /,
      );
  }
  
  sub type { shift->_data->{ type }}
  
  sub new {
      my $class = shift;
      croak "Generators must be coderefs, not " . ref($_[0])
          unless ref( $_[0] ) eq 'CODE';
      $class->SUPER::new( @_ );
  }
  
  sub generate {
      my $self = shift;
      my ( $import_class, @args ) = @_;
      my $ref = $self->( $self->exported_by, $import_class, @args );
  
      return Exporter::Declare::Export::Sub->new(
          $ref,
          %{ $self->_data },
      ) if $self->type eq 'sub';
  
      return Exporter::Declare::Export::Variable->new(
          $ref,
          %{ $self->_data },
      ) if $self->type eq 'variable';
  
      return $self->type->new(
          $ref,
          %{ $self->_data },
      );
  }
  
  sub inject {
      my $self = shift;
      my ( $class, $name, @args ) = @_;
      $self->generate( $class, @args )->inject( $class, $name );
  }
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Export::Generator - Export class for exports that should be
  generated when imported.
  
  =head1 DESCRIPTION
  
  Export class for exports that should be generated when imported.
  
  =head1 OVERRIDEN METHODS
  
  =over 4
  
  =item $class->new( $ref, $ref, exported_by => $package, type => $type, %data )
  
  You must specify the type as 'sub' or 'variable'.
  
  =item $export->inject( $package, $name, @args )
  
  Calls generate() with @args to create a generated export. The new export is
  then injected.
  
  =back
  
  =head1 ADDITIONAL METHODS
  
  =over 4
  
  =item $new = $export->generate( $import_class, @args )
  
  Generates a new export object.
  
  =item $type = $export->type()
  
  Returns the type of object to be generated (sub or variable)
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_EXPORT_GENERATOR

$fatpacked{"Exporter/Declare/Export/Sub.pm"} = <<'EXPORTER_DECLARE_EXPORT_SUB';
  package Exporter::Declare::Export::Sub;
  use strict;
  use warnings;
  
  use base 'Exporter::Declare::Export';
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Export::Sub - Export class for subs which are exported.
  
  =head1 DESCRIPTION
  
  Currently does not do anything L<Exporter::Declare::Export> does not.
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_EXPORT_SUB

$fatpacked{"Exporter/Declare/Export/Variable.pm"} = <<'EXPORTER_DECLARE_EXPORT_VARIABLE';
  package Exporter::Declare::Export::Variable;
  use strict;
  use warnings;
  
  use base 'Exporter::Declare::Export';
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Export::Variable - Export class for variables which are
  exported.
  
  =head1 DESCRIPTION
  
  Export class for variables which are exported. Currently does not expand upon
  L<Exporter::Declare::Export> in any way.
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_EXPORT_VARIABLE

$fatpacked{"Exporter/Declare/Magic.pm"} = <<'EXPORTER_DECLARE_MAGIC';
  package Exporter::Declare::Magic;
  use strict;
  use warnings;
  
  use Devel::Declare::Parser;
  use aliased 'Exporter::Declare::Magic::Sub';
  use aliased 'Exporter::Declare::Export::Generator';
  use Carp qw/croak/;
  our @CARP_NOT = qw/
      Exporter::Declare
      Exporter::Declare::Specs
      Exporter::Declare::Meta
      Exporter::Declare::Magic
  /;
  
  BEGIN {
      die "Devel::Declare::Parser version >= 0.017 is required for -magic\n"
          unless $Devel::Declare::Parser::VERSION gt '0.016';
  }
  
  use Devel::Declare::Parser::Sublike;
  
  use Exporter::Declare
      'default_exports',
      export             => { -as => 'ed_export' },
      gen_export         => { -as => 'ed_gen_export' },
      default_export     => { -as => 'ed_default_export' },
      gen_default_export => { -as => 'ed_gen_default_export' };
  
  default_exports qw/
      parsed_exports
      parsed_default_exports
  /;
  
  parsed_default_exports( sublike => qw/parser/ );
  
  parsed_default_exports( export => qw/
      export
      gen_export
      default_export
      gen_default_export
  /);
  
  Exporter::Declare::Meta->add_hash_metric( 'parsers' );
  
  sub export {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      _export( $class, undef, @_ );
  }
  
  sub gen_export {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      _export( $class, Generator(), @_ );
  }
  
  sub default_export {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->export_tags_push( 'default', _export( $class, undef, @_ ));
  }
  
  sub gen_default_export {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      my $meta = $class->export_meta;
      $meta->export_tags_push( 'default', _export( $class, Generator(), @_ ));
  }
  
  sub _export {
      my %params = Exporter::Declare::_parse_export_params( @_ );
      my ($parser) = @{ $params{args} };
      if ( $parser ) {
          my $ec = $params{export_class};
          if ( $ec && $ec eq Generator ) {
              $params{extra_exporter_props} = { parser => $parser, type => Sub };
          }
          else {
              $params{export_class} = Sub;
              $params{extra_exporter_props} = { parser => $parser };
          }
      }
      Exporter::Declare::_add_export( %params );
  }
  
  sub parser {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      my $name = shift;
      my $code = pop;
      croak "You must provide a name to parser()"
          if !$name || ref $name;
      croak "Too many parameters passed to parser()"
          if @_ && defined $_[0];
      $code ||= $class->can( $name );
      croak "Could not find code for parser '$name'"
          unless $code;
  
      $class->export_meta->parsers_add( $name, $code );
  }
  
  sub parsed_exports {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      my ( $parser, @items ) = @_;
      croak "no parser specified" unless $parser;
      _export( $class, Sub(), $_, $parser ) for @items;
  }
  
  sub parsed_default_exports {
      my $class = Exporter::Declare::_find_export_class( \@_ );
      my ( $parser, @names ) = @_;
      croak "no parser specified" unless $parser;
  
      for my $name ( @names ) {
          _export( $class, Sub(), $name, $parser );
          $class->export_meta->export_tags_push( 'default', $name );
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Exporter::Declare::Magic - Enhance Exporter::Declare with some fancy magic.
  
  =head1 DESCRIPTION
  
  =head1 SYNOPSIS
  
      package Some::Exporter;
      use Exporter::Declare '-magic';
  
      ... #Same as the basic exporter synopsis
  
      #Quoting is not necessary unless you have space or special characters
      export another_sub;
      export parsed_sub parser;
  
      # no 'sub' keyword, not a typo
      export anonymous_export {
          ...
      }
      #No semicolon, not a typo
  
      export parsed_anon parser {
          ...
      }
  
      # Same as export
      default_export name { ... }
  
      # No quoting required
      export $VAR;
      export %VAR;
  
      my $iterator = 'a';
      gen_export unique_class_id {
          my $current = $iterator++;
          return sub { $current };
      }
  
      gen_default_export '$my_letter' {
          my $letter = $iterator++;
          return \$letter;
      }
  
      parser myparser {
          ... See Devel::Declare
      }
  
      parsed_exports parser => qw/ parsed_sub_a parsed_sub_b /;
      parsed_default_exports parser_b => qw/ parsed_sub_c /;
  
  =head1 API
  
  These all work fine in function or method form, however the syntax sugar will
  only work in function form.
  
  =over 4
  
  =item parsed_exports( $parser, @exports )
  
  Add exports that should use a 'Devel::Declare' based parser. The parser should
  be the name of a registered L<Devel::Declare::Interface> parser, or the name of
  a parser sub created using the parser() function.
  
  =item parsed_default_exports( $parser, @exports )
  
  Same as parsed_exports(), except exports are added to the -default tag.
  
  =item parser name { ... }
  
  =item parser name => \&code
  
  Define a parser. You need to be familiar with Devel::Declare to make use of
  this.
  
  =item export( $name )
  
  =item export( $name, $ref )
  
  =item export( $name, $parser )
  
  =item export( $name, $parser, $ref )
  
  =item export name { ... }
  
  =item export name parser { ... }
  
  export is a keyword that lets you export any 1 item at a time. The item can be
  exported by name, name+ref, or name+parser+ref. You can also use it without
  parentheses or quotes followed by a codeblock.
  
  =item default_export( $name )
  
  =item default_export( $name, $ref )
  
  =item default_export( $name, $parser )
  
  =item default_export( $name, $parser, $ref )
  
  =item default_export name { ... }
  
  =item default_export name parser { ... }
  
  =item gen_export( $name )
  
  =item gen_export( $name, $ref )
  
  =item gen_export( $name, $parser )
  
  =item gen_export( $name, $parser, $ref )
  
  =item gen_export name { ... }
  
  =item gen_export name parser { ... }
  
  =item gen_default_export( $name )
  
  =item gen_default_export( $name, $ref )
  
  =item gen_default_export( $name, $parser )
  
  =item gen_default_export( $name, $parser, $ref )
  
  =item gen_default_export name { ... }
  
  =item gen_default_export name parser { ... }
  
  These all act just like export(), except that they add subrefs as generators,
  and/or add exports to the -default tag.
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_MAGIC

$fatpacked{"Exporter/Declare/Magic/Parser.pm"} = <<'EXPORTER_DECLARE_MAGIC_PARSER';
  package Exporter::Declare::Magic::Parser;
  use strict;
  use warnings;
  
  use base 'Devel::Declare::Parser';
  use Devel::Declare::Interface;
  BEGIN { Devel::Declare::Interface::register_parser( 'export' )};
  
  __PACKAGE__->add_accessor( '_inject' );
  __PACKAGE__->add_accessor( 'parser' );
  
  sub inject {
      my $self = shift;
      my @out;
  
      if( my $items = $self->_inject() ) {
          my $ref = ref( $items );
          if ( $ref eq 'ARRAY' ) {
              push @out => @$items;
          }
          elsif ( !$ref ) {
              push @out => $items;
          }
          else {
              $self->bail( "$items is not a valid injection" );
          }
      }
      return @out;
  }
  
  sub _check_parts {
      my $self = shift;
      $self->bail( "You must provide a name to " . $self->name . "()" )
          if ( !$self->parts || !@{ $self->parts });
  
      if ( @{ $self->parts } > 3 ) {
          ( undef, undef, undef, my @bad ) = @{ $self->parts };
          $self->bail(
              "Syntax error near: " . join( ' and ',
                  map { $self->format_part($_)} @bad
              )
          );
      }
  }
  
  sub sort_parts {
      my $self = shift;
  
      if ($self->parts->[0] =~ m/^[\%\$\&\@]/) {
          $self->parts->[0] = [
              $self->parts->[0],
              undef,
          ];
      }
  
      $self->bail(
          "Parsing Error, unrecognized tokens: "
          . join( ', ', map {"'$_'"} $self->has_non_string_or_quote_parts )
      ) if $self->has_non_string_or_quote_parts;
  
      my ( @names, @specs );
      for my $part (@{ $self->parts }) {
          $self->bail( "Bad part: $part" ) unless ref($part);
          $part->[1] && $part->[1] eq '('
              ? ( push @specs => $part )
              : ( push @names => $part )
      }
  
      if ( @names > 2 ) {
          ( undef, undef, my @bad ) = @names;
          $self->bail(
              "Syntax error near: " . join( ' and ',
                  map { $self->format_part($_)} @bad
              )
          );
      }
  
      return ( \@names, \@specs );
  }
  
  sub strip_prototype {
      my $self = shift;
      my $parts = $self->parts;
      return unless @$parts > 3;
      return unless ref( $parts->[2] );
      return unless $parts->[2]->[0] eq 'sub';
      return unless ref( $parts->[3] );
      return unless $parts->[3]->[1] eq '(';
      return unless !$parts->[2]->[1];
      $self->prototype(
            $parts->[3]->[1]
          . $parts->[3]->[0]
          . $self->end_quote($parts->[3]->[1])
      );
      delete $parts->[3];
  }
  
  sub rewrite {
      my $self = shift;
  
      $self->strip_prototype;
      $self->_check_parts;
  
      my $is_arrow = $self->parts->[1]
                  && ($self->parts->[1] eq '=>' || $self->parts->[1] eq ',');
      if ( $is_arrow && $self->parts->[2] ) {
          my $is_ref = !ref( $self->parts->[2] );
          my $is_sub = $is_ref ? 0 : $self->parts->[2]->[0] eq 'sub';
  
          if (( $is_arrow && $is_ref )
          || ( @{ $self->parts } == 1 )) {
              $self->new_parts([ $self->parts->[0], $self->parts->[2] ]);
              return 1;
          }
          elsif (( $is_arrow && $is_sub )
          || ( @{ $self->parts } == 1 )) {
              $self->new_parts([ $self->parts->[0] ]);
              return 1;
          }
      }
  
      my ( $names, $specs ) = $self->sort_parts();
      $self->parser( $names->[1] ? $names->[1]->[0] : undef );
      push @$names => 'undef' unless @$names > 1;
      $self->new_parts( $names );
  
      if ( @$specs ) {
          $self->bail( "Too many spec defenitions" )
              if @$specs > 1;
          my $specs = eval "{ " . $specs->[0]->[0] . " }"
                || $self->bail($@);
          $self->_inject( delete $specs->{ inject });
      }
  
      1;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Exporter::Declare::Magic::Parser - The parser behind the export() magic.
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_MAGIC_PARSER

$fatpacked{"Exporter/Declare/Magic/Sub.pm"} = <<'EXPORTER_DECLARE_MAGIC_SUB';
  package Exporter::Declare::Magic::Sub;
  use strict;
  use warnings;
  
  use base 'Exporter::Declare::Export::Sub';
  
  sub inject {
      my $self = shift;
      my ($class, $name) = @_;
  
      $self->SUPER::inject( $class, $name );
  
      return unless $self->parser;
  
      my $parser_sub = $self->exported_by->export_meta->parsers_get( $self->parser );
  
      if ( $parser_sub ) {
          require Devel::Declare;
          Devel::Declare->setup_for(
              $class,
              { $name => { const => $parser_sub } }
          );
      }
      else {
          require Devel::Declare::Interface;
          require Exporter::Declare::Magic::Parser;
          Devel::Declare::Interface::enhance(
              $class,
              $name,
              $self->parser,
          );
      }
  }
  
  sub parser {
      my $self = shift;
      return $self->_data->{parser};
  }
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Magic::Sub - Export class for subs which are exported.
  
  =head1 DESCRIPTION
  
  Export class for subs which are exported. Overrides inject() in order to hook
  into L<Devel::Declare> on parsed exports.
  
  =head1 OVERRIDEN METHODS
  
  =over 4
  
  =item $export->inject( $class, $name );
  
  Inject the sub, and apply the L<Devel::Declare> magic.
  
  =back
  
  =head1 NEW METHODS
  
  =over 4
  
  =item $parser_name = export->parser()
  
  Get the name of the parse this sub should use with L<Devel::Declare> empty when
  no parse should be used.
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_MAGIC_SUB

$fatpacked{"Exporter/Declare/Meta.pm"} = <<'EXPORTER_DECLARE_META';
  package Exporter::Declare::Meta;
  use strict;
  use warnings;
  
  use Scalar::Util qw/blessed reftype/;
  use Carp qw/croak/;
  use aliased 'Exporter::Declare::Export::Sub';
  use aliased 'Exporter::Declare::Export::Variable';
  use aliased 'Exporter::Declare::Export::Alias';
  use Meta::Builder;
  
  accessor 'export_meta';
  
  hash_metric exports => (
      add => sub {
          my $self = shift;
          my ( $data, $metric, $action, $item, $ref ) = @_;
          croak "Exports must be instances of 'Exporter::Declare::Export'"
              unless blessed( $ref ) && $ref->isa('Exporter::Declare::Export');
  
          my ( $type, $name ) = ( $item =~ m/^([\&\%\@\$])?(.*)$/ );
          $type ||= '&';
          my $fullname = "$type$name";
  
          $self->default_hash_add( $data, $metric, $action, $fullname, $ref );
  
          push @{ $self->export_tags->{all} } => $fullname;
      },
      get => sub {
          my $self = shift;
          my ( $data, $metric, $action, $item ) = @_;
  
          croak "exports_get() does not accept a tag as an argument"
              if $item =~ m/^[:-]/;
  
          my ( $type, $name ) = ( $item =~ m/^([\&\%\@\$])?(.*)$/ );
          $type ||= '&';
          my $fullname = "$type$name";
  
          return $self->default_hash_get( $data, $metric, $action, $fullname )
              || croak $self->package . " does not export '$fullname'"
      },
      merge => sub {
          my $self = shift;
          my ( $data, $metric, $action, $merge ) = @_;
          my $newmerge = {};
  
          for my $item ( keys %$merge ) {
              my $value = $merge->{ $item };
              next if $value->isa(Alias);
              $newmerge->{$item} = $value;
          }
  
          $self->default_hash_merge( $data, $metric, $action, $newmerge );
      }
  );
  
  hash_metric options => (
      add => sub {
          my $self = shift;
          my ( $data, $metric, $action, $item ) = @_;
  
          croak "'$item' is already a tag, you can't also make it an option."
              if $self->export_tags_has( $item );
          croak "'$item' is already an argument, you can't also make it an option."
              if $self->arguments_has( $item );
  
          $self->default_hash_add( $data, $metric, $action, $item, 1 );
      },
  );
  
  hash_metric arguments => (
      add => sub {
          my $self = shift;
          my ( $data, $metric, $action, $item ) = @_;
  
          croak "'$item' is already a tag, you can't also make it an argument."
              if $self->export_tags_has( $item );
          croak "'$item' is already an option, you can't also make it an argument."
              if $self->options_has( $item );
  
          $self->default_hash_add( $data, $metric, $action, $item, 1 );
      },
      merge => sub {
          my $self = shift;
          my ( $data, $metric, $action, $merge ) = @_;
          my $newmerge = { %$merge };
          delete $newmerge->{suffix};
          delete $newmerge->{prefix};
          $self->default_hash_merge( $data, $metric, $action, $newmerge );
      }
  );
  
  lists_metric export_tags => (
       push => sub {
          my $self = shift;
          my ( $data, $metric, $action, $item, @args ) = @_;
  
          croak "'$item' is a reserved tag, you cannot override it."
              if $item eq 'all';
          croak "'$item' is already an option, you can't also make it a tag."
              if $self->options_has( $item );
          croak "'$item' is already an argument, you can't also make it a tag."
              if $self->arguments_has( $item );
  
          $self->default_list_push( $data, $metric, $action, $item, @args );
      },
      merge => sub {
          my $self = shift;
          my ( $data, $metric, $action, $merge ) = @_;
          my $newmerge = {};
          my %aliases = ( map {
              my ( $name ) = ( m/^&?(.*)$/);
              ( $name => 1, "&$name" => 1 )
          } @{ $merge->{alias} });
  
          for my $item ( keys %$merge ) {
              my $values = $merge->{ $item };
              $newmerge->{$item} = [ grep { !$aliases{$_} } @$values ];
          }
  
          $self->default_list_merge( $data, $metric, $action, $newmerge );
      }
  );
  
  sub new {
      my $class = shift;
      my $self = $class->SUPER::new(
          @_,
          export_tags => { all => [], default => [], alias => [] },
          arguments => { prefix => 1, suffix => 1 },
      );
      $self->add_alias;
      return $self;
  }
  
  sub new_from_exporter {
      my $class = shift;
      my ( $exporter ) = @_;
      my $self = $class->new( $exporter );
      my %seen;
      my ($exports) = $self->get_ref_from_package('@EXPORT');
      my ($export_oks) = $self->get_ref_from_package('@EXPORT_OK');
      my ($tags) = $self->get_ref_from_package('%EXPORT_TAGS');
      $self->exports_add( @$_ ) for map {
          my ( $ref, $name ) = $self->get_ref_from_package( $_ );
          if ( $name =~ m/^\&/ ) {
              Sub->new( $ref, exported_by => $exporter );
          }
          else {
              Variable->new( $ref, exported_by => $exporter );
          }
          [ $name, $ref ];
      } grep { !$seen{$_}++ } @$exports, @$export_oks;
      $self->export_tags_push( 'default', @$exports )
          if @$exports;
      $self->export_tags_push( $_, $tags->{$_} ) for keys %$tags;
      return $self;
  }
  
  sub add_alias {
      my $self = shift;
      my $package = $self->package;
      my ( $alias ) = ( $package =~ m/([^:]+)$/ );
      $self->exports_add( $alias, Alias->new( sub { $package }, exported_by => $package ));
      $self->export_tags_push( 'alias', $alias );
  }
  
  sub is_tag {
      my $self = shift;
      my ( $name ) = @_;
      return exists $self->export_tags->{$name} ? 1 : 0;
  }
  
  sub get_ref_from_package {
      my $self = shift;
      my ( $item ) = @_;
      use Carp qw/confess/;
      confess unless $item;
      my ( $type, $name ) = ($item =~ m/^([\&\@\%\$]?)(.*)$/);
      $type ||= '&';
      my $fullname = "$type$name";
      my $ref = $self->package . '::' . $name;
  
      no strict 'refs';
      return( \&{ $ref }, $fullname ) if !$type || $type eq '&';
      return( \${ $ref }, $fullname ) if $type eq '$';
      return( \@{ $ref }, $fullname ) if $type eq '@';
      return( \%{ $ref }, $fullname ) if $type eq '%';
      croak "'$item' cannot be exported"
  }
  
  sub reexport {
      my $self = shift;
      my ( $exporter ) = @_;
      my $meta = $exporter->can( 'export_meta' )
          ? $exporter->export_meta()
          : __PACKAGE__->new_from_exporter( $exporter );
      $self->merge( $meta );
  }
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Meta - The mata object which stoes meta-data for all
  exporters.
  
  =head1 DESCRIPTION
  
  All classes that use Exporter::Declare have an associated Meta object. Meta
  objects track available exports, tags, and options.
  
  =head1 METHODS
  
  =over 4
  
  =item $class->new( $package )
  
  Created a meta object for the specified package. Also injects the export_meta()
  sub into the package namespace that returns the generated meta object.
  
  =item $class->new_from_exporter( $package )
  
  Create a meta object for a package that already uses Exporter.pm. This will not
  turn the class into an Exporter::Declare package, but it will create a meta
  object and export_meta() method on it. This si primarily used for reexport
  purposes.
  
  =item $package = $meta->package()
  
  Get the name of the package with which the meta object is associated.
  
  =item $meta->add_alias()
  
  Usually called at construction to add a package alias function to the exports.
  
  =item $meta->add_export( $name, $ref )
  
  Add an export, name should be the item name with sigil (assumed to be sub if
  there is no sigil). $ref should be a ref blessed as an
  L<Exporter::Declare::Export> subclass.
  
  =item $meta->get_export( $name )
  
  Retrieve the L<Exporter::Declare::Export> object by name. Name should be the
  item name with sigil, assumed to be sub when sigil is missing.
  
  =item $meta->export_tags_push( $name, @items )
  
  Add @items to the specified tag. Tag will be created if it does not already
  exist. $name should be the tag name B<WITHOUT> -/: prefix.
  
  =item $bool = $meta->is_tag( $name )
  
  Check if a tag with the given name exists.  $name should be the tag name
  B<WITHOUT> -/: prefix.
  
  =item @list = $meta->get_tag( $name )
  
  Get the list of items associated with the specified tag.  $name should be the
  tag name B<WITHOUT> -/: prefix.
  
  =item $meta->add_options( @names )
  
  Add import options by name. These will be boolean options that take no
  arguments.
  
  =item $meta->add_arguments( @names )
  
  Add import options that slurp in the next argument as a value.
  
  =item $bool = $meta->is_option( $name )
  
  Check if the specifed name is an option.
  
  =item $bool = $meta->is_argument( $name )
  
  Check if the specifed name is an option that takes an argument.
  
  =item $meta->add_parser( $name, sub { ... })
  
  Add a parser sub that should be associated with exports via L<Devel::Declare>
  
  =item $meta->get_parser( $name )
  
  Get a parser by name.
  
  =item $ref = $meta->get_ref_from_package( $item )
  
  Returns a reference to a specific package variable or sub.
  
  =item $meta->reexport( $package )
  
  Re-export the exports in the provided package. Package may be an
  L<Exporter::Declare> based package or an L<Exporter> based package.
  
  =item $meta->merge( $meta2 )
  
  Merge-in the exports and tags of the second meta object.
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_META

$fatpacked{"Exporter/Declare/Specs.pm"} = <<'EXPORTER_DECLARE_SPECS';
  package Exporter::Declare::Specs;
  use strict;
  use warnings;
  
  use Carp qw/croak/;
  our @CARP_NOT = qw/Exporter::Declare/;
  
  sub new {
      my $class = shift;
      my ( $package, @args ) = @_;
      my $self = bless( [$package,{},{},[]], $class );
      @args = (':default') unless @args;
      $self->_process( "import list", @args );
      return $self;
  }
  
  sub package  { shift->[0] }
  sub config   { shift->[1] }
  sub exports  { shift->[2] }
  sub excludes { shift->[3] }
  
  sub export {
      my $self = shift;
      my ( $dest ) = @_;
      for my $item ( keys %{ $self->exports }) {
          my ( $export, $conf, $args ) = @{ $self->exports->{$item} };
          my ( $sigil, $name ) = ( $item =~ m/^([\&\%\$\@])(.*)$/ );
          $name = $conf->{as} || join(
              '',
              $conf->{prefix} || $self->config->{prefix} || '',
              $name,
              $conf->{suffix} || $self->config->{suffix} || '',
          );
          $export->inject( $dest, $name, @$args );
      }
  }
  
  sub add_export {
      my $self = shift;
      my ( $name, $value, $config ) = @_;
      my $type = ref $value eq 'CODE' ? 'Sub' : 'Variable';
      "Exporter::Declare::Export::$type"->new( $value, exported_by => scalar caller() );
      $self->exports->{$name} = [
          $value,
          $config || {},
          [],
      ];
  }
  
  sub _process {
      my $self = shift;
      my ( $tag, @args ) = @_;
      my $argnum = 0;
      while ( my $item = shift( @args )) {
          croak "not sure what to do with $item ($tag argument: $argnum)"
              if ref $item;
          $argnum++;
  
          if ( $item =~ m/^(!?)[:-](.*)$/ ) {
              my ( $neg, $param ) = ( $1, $2 );
              if ( $self->package->export_meta->arguments_has( $param )) {
                  $self->config->{$param} = shift( @args );
                  $argnum++;
                  next;
              }
              else {
                  $self->config->{$param} = ref( $args[0] ) ? $args[0] : !$neg;
              }
          }
  
          if ( $item =~ m/^!(.*)$/ ) {
              $self->_exclude_item( $1 )
          }
          elsif ( my $type = ref( $args[0] )) {
              my $arg = shift( @args );
              $argnum++;
              if ( $type eq 'ARRAY' ) {
                  $self->_include_item( $item, undef, $arg );
              }
              elsif ( $type eq 'HASH' ) {
                  $self->_include_item( $item, $arg, undef );
              }
              else {
                  croak "Not sure what to do with $item => $arg ($tag arguments: "
                  . ($argnum - 1) . " and $argnum)";
              }
          }
          else {
              $self->_include_item( $item )
          }
      }
      delete $self->exports->{$_} for @{ $self->excludes };
  }
  
  sub _item_name { my $in = shift; $in =~ m/^[\&\$\%\@]/ ? $in : "\&$in" }
  
  sub _exclude_item {
      my $self = shift;
      my ( $item ) = @_;
  
      if ( $item =~ m/^[:-](.*)$/ ) {
          $self->_exclude_item( $_ )
              for $self->_export_tags_get( $1 );
          return;
      }
  
      push @{ $self->excludes } => _item_name($item);
  }
  
  sub _include_item {
      my $self = shift;
      my ( $item, $conf, $args ) = @_;
      $conf ||= {};
      $args ||= [];
  
      use Carp qw/confess/;
      confess $item if $item =~ m/^&?aaa_/;
  
      push @$args => @{ delete $conf->{'-args'} }
          if defined $conf->{'-args'};
  
      for my $key ( keys %$conf ) {
          next if $key =~ m/^[:-]/;
          push @$args => ( $key, delete $conf->{$key} );
      }
  
      if ( $item =~ m/^[:-](.*)$/ ) {
          my $name = $1;
          return if $self->package->export_meta->options_has( $name );
          for my $tagitem ( $self->_export_tags_get( $name ) ) {
              my ( $negate, $name ) = ( $tagitem =~ m/^(!)?(.*)$/ );
              if ( $negate ) {
                  $self->_exclude_item( $name );
              }
              else {
                  $self->_include_item( $tagitem, $conf, $args );
              }
          }
          return;
      }
  
      $item = _item_name($item);
  
      my $existing = $self->exports->{ $item };
  
      unless ( $existing ) {
          $existing = [ $self->_get_item( $item ), {}, []];
          $self->exports->{ $item } = $existing;
      }
  
      push @{ $existing->[2] } => @$args;
      for my $param (  keys %$conf ) {
          my ( $name ) = ( $param =~ m/^[-:](.*)$/ );
          $existing->[1]->{$name} = $conf->{$param};
      }
  }
  
  sub _get_item {
      my $self = shift;
      my ( $name ) = @_;
      $self->package->export_meta->exports_get( $name );
  }
  
  sub _export_tags_get {
      my $self = shift;
      my ( $name ) = @_;
      $self->package->export_meta->export_tags_get( $name );
  }
  
  1;
  
  =head1 NAME
  
  Exporter::Declare::Specs - Import argument parser for Exporter::Declare
  
  =head1 DESCRIPTION
  
  Import arguments cna get complicated. All arguments are assumed to be exports
  unless they have a - or : prefix. The prefix may denote a tag, a boolean
  option, or an option that takes the next argument as a value. In addition
  almost all these can be negated with the ! prefix.
  
  This class takes care of parsing the import arguments and generating data
  structures that can be used to find what the exporter needs to know.
  
  =head1 METHODS
  
  =over 4
  
  =item $class->new( $package, @args )
  
  Create a new instance and parse @args.
  
  =item $specs->package()
  
  Get the name of the package that should do the exporting.
  
  =item $hashref = $specs->config()
  
  Get the configuration hash, All specified options and tags are the keys. The
  value will be true/false/undef for tags/boolean options. For options that take
  arguments the value will be that argument. When a config hash is provided to a
  tag it will be the value.
  
  =item $hashref = $specs->exports()
  
  Get the exports hash. The keys are names of the exports. Values are an array
  containing the export, item specific config hash, and arguments array. This is
  generally not intended for direct consumption.
  
  =item $arrayref = $specs->excludes()
  
  Get the arrayref containing the names of all excluded exports.
  
  =item $specs->export( $package )
  
  Do the actual exporting. All exports will be injected into $package.
  
  =item $specs->add_export( $name, $value )
  
  =item $specs->add_export( $name, $value, \%config )
  
  Add an export. Name is required, including sigil. Value is required, if it is a
  sub it will be blessed as a ::Sub, otherwise blessed as a ::Variable.
  
      $specs->add_export( '&foo' => sub { return 'foo' });
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Exporter-Declare is free software; Standard perl licence.
  
  Exporter-Declare is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the license for more details.
EXPORTER_DECLARE_SPECS

$fatpacked{"JSON/PP.pm"} = <<'JSON_PP';
  package JSON::PP;
  
  # JSON-2.0
  
  use 5.005;
  use strict;
  use base qw(Exporter);
  use overload ();
  
  use Carp ();
  use B ();
  #use Devel::Peek;
  
  $JSON::PP::VERSION = '2.27104';
  
  @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
  
  # instead of hash-access, i tried index-access for speed.
  # but this method is not faster than what i expected. so it will be changed.
  
  use constant P_ASCII                => 0;
  use constant P_LATIN1               => 1;
  use constant P_UTF8                 => 2;
  use constant P_INDENT               => 3;
  use constant P_CANONICAL            => 4;
  use constant P_SPACE_BEFORE         => 5;
  use constant P_SPACE_AFTER          => 6;
  use constant P_ALLOW_NONREF         => 7;
  use constant P_SHRINK               => 8;
  use constant P_ALLOW_BLESSED        => 9;
  use constant P_CONVERT_BLESSED      => 10;
  use constant P_RELAXED              => 11;
  
  use constant P_LOOSE                => 12;
  use constant P_ALLOW_BIGNUM         => 13;
  use constant P_ALLOW_BAREKEY        => 14;
  use constant P_ALLOW_SINGLEQUOTE    => 15;
  use constant P_ESCAPE_SLASH         => 16;
  use constant P_AS_NONBLESSED        => 17;
  
  use constant P_ALLOW_UNKNOWN        => 18;
  
  use constant OLD_PERL => $] < 5.008 ? 1 : 0;
  
  BEGIN {
      my @xs_compati_bit_properties = qw(
              latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
              allow_blessed convert_blessed relaxed allow_unknown
      );
      my @pp_bit_properties = qw(
              allow_singlequote allow_bignum loose
              allow_barekey escape_slash as_nonblessed
      );
  
      # Perl version check, Unicode handling is enable?
      # Helper module sets @JSON::PP::_properties.
      if ($] < 5.008 ) {
          my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
          eval qq| require $helper |;
          if ($@) { Carp::croak $@; }
      }
  
      for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
          my $flag_name = 'P_' . uc($name);
  
          eval qq/
              sub $name {
                  my \$enable = defined \$_[1] ? \$_[1] : 1;
  
                  if (\$enable) {
                      \$_[0]->{PROPS}->[$flag_name] = 1;
                  }
                  else {
                      \$_[0]->{PROPS}->[$flag_name] = 0;
                  }
  
                  \$_[0];
              }
  
              sub get_$name {
                  \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
              }
          /;
      }
  
  }
  
  
  
  # Functions
  
  my %encode_allow_method
       = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
                            allow_blessed convert_blessed indent indent_length allow_bignum
                            as_nonblessed
                          /;
  my %decode_allow_method
       = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
                            allow_barekey max_size relaxed/;
  
  
  my $JSON; # cache
  
  sub encode_json ($) { # encode
      ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
  }
  
  
  sub decode_json { # decode
      ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
  }
  
  # Obsoleted
  
  sub to_json($) {
     Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
  }
  
  
  sub from_json($) {
     Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
  }
  
  
  # Methods
  
  sub new {
      my $class = shift;
      my $self  = {
          max_depth   => 512,
          max_size    => 0,
          indent      => 0,
          FLAGS       => 0,
          fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
          indent_length => 3,
      };
  
      bless $self, $class;
  }
  
  
  sub encode {
      return $_[0]->PP_encode_json($_[1]);
  }
  
  
  sub decode {
      return $_[0]->PP_decode_json($_[1], 0x00000000);
  }
  
  
  sub decode_prefix {
      return $_[0]->PP_decode_json($_[1], 0x00000001);
  }
  
  
  # accessor
  
  
  # pretty printing
  
  sub pretty {
      my ($self, $v) = @_;
      my $enable = defined $v ? $v : 1;
  
      if ($enable) { # indent_length(3) for JSON::XS compatibility
          $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
      }
      else {
          $self->indent(0)->space_before(0)->space_after(0);
      }
  
      $self;
  }
  
  # etc
  
  sub max_depth {
      my $max  = defined $_[1] ? $_[1] : 0x80000000;
      $_[0]->{max_depth} = $max;
      $_[0];
  }
  
  
  sub get_max_depth { $_[0]->{max_depth}; }
  
  
  sub max_size {
      my $max  = defined $_[1] ? $_[1] : 0;
      $_[0]->{max_size} = $max;
      $_[0];
  }
  
  
  sub get_max_size { $_[0]->{max_size}; }
  
  
  sub filter_json_object {
      $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
      $_[0];
  }
  
  sub filter_json_single_key_object {
      if (@_ > 1) {
          $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
      }
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
      $_[0];
  }
  
  sub indent_length {
      if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
          Carp::carp "The acceptable range of indent_length() is 0 to 15.";
      }
      else {
          $_[0]->{indent_length} = $_[1];
      }
      $_[0];
  }
  
  sub get_indent_length {
      $_[0]->{indent_length};
  }
  
  sub sort_by {
      $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
      $_[0];
  }
  
  sub allow_bigint {
      Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
  }
  
  ###############################
  
  ###
  ### Perl => JSON
  ###
  
  
  { # Convert
  
      my $max_depth;
      my $indent;
      my $ascii;
      my $latin1;
      my $utf8;
      my $space_before;
      my $space_after;
      my $canonical;
      my $allow_blessed;
      my $convert_blessed;
  
      my $indent_length;
      my $escape_slash;
      my $bignum;
      my $as_nonblessed;
  
      my $depth;
      my $indent_count;
      my $keysort;
  
  
      sub PP_encode_json {
          my $self = shift;
          my $obj  = shift;
  
          $indent_count = 0;
          $depth        = 0;
  
          my $idx = $self->{PROPS};
  
          ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
              $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
           = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
                      P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
  
          ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
  
          $keysort = $canonical ? sub { $a cmp $b } : undef;
  
          if ($self->{sort_by}) {
              $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
                       : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
                       : sub { $a cmp $b };
          }
  
          encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
               if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
  
          my $str  = $self->object_to_json($obj);
  
          $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
  
          unless ($ascii or $latin1 or $utf8) {
              utf8::upgrade($str);
          }
  
          if ($idx->[ P_SHRINK ]) {
              utf8::downgrade($str, 1);
          }
  
          return $str;
      }
  
  
      sub object_to_json {
          my ($self, $obj) = @_;
          my $type = ref($obj);
  
          if($type eq 'HASH'){
              return $self->hash_to_json($obj);
          }
          elsif($type eq 'ARRAY'){
              return $self->array_to_json($obj);
          }
          elsif ($type) { # blessed object?
              if (blessed($obj)) {
  
                  return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
  
                  if ( $convert_blessed and $obj->can('TO_JSON') ) {
                      my $result = $obj->TO_JSON();
                      if ( defined $result and ref( $result ) ) {
                          if ( refaddr( $obj ) eq refaddr( $result ) ) {
                              encode_error( sprintf(
                                  "%s::TO_JSON method returned same object as was passed instead of a new one",
                                  ref $obj
                              ) );
                          }
                      }
  
                      return $self->object_to_json( $result );
                  }
  
                  return "$obj" if ( $bignum and _is_bignum($obj) );
                  return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
  
                  encode_error( sprintf("encountered object '%s', but neither allow_blessed "
                      . "nor convert_blessed settings are enabled", $obj)
                  ) unless ($allow_blessed);
  
                  return 'null';
              }
              else {
                  return $self->value_to_json($obj);
              }
          }
          else{
              return $self->value_to_json($obj);
          }
      }
  
  
      sub hash_to_json {
          my ($self, $obj) = @_;
          my @res;
  
          encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                           if (++$depth > $max_depth);
  
          my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
          my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
  
          for my $k ( _sort( $obj ) ) {
              if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
              push @res, string_to_json( $self, $k )
                            .  $del
                            . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
          }
  
          --$depth;
          $self->_down_indent() if ($indent);
  
          return   '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' )  . '}';
      }
  
  
      sub array_to_json {
          my ($self, $obj) = @_;
          my @res;
  
          encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                           if (++$depth > $max_depth);
  
          my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
  
          for my $v (@$obj){
              push @res, $self->object_to_json($v) || $self->value_to_json($v);
          }
  
          --$depth;
          $self->_down_indent() if ($indent);
  
          return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
      }
  
  
      sub value_to_json {
          my ($self, $value) = @_;
  
          return 'null' if(!defined $value);
  
          my $b_obj = B::svref_2object(\$value);  # for round trip problem
          my $flags = $b_obj->FLAGS;
  
          return $value # as is 
              if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
  
          my $type = ref($value);
  
          if(!$type){
              return string_to_json($self, $value);
          }
          elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
              return $$value == 1 ? 'true' : 'false';
          }
          elsif ($type) {
              if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
                  return $self->value_to_json("$value");
              }
  
              if ($type eq 'SCALAR' and defined $$value) {
                  return   $$value eq '1' ? 'true'
                         : $$value eq '0' ? 'false'
                         : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
                         : encode_error("cannot encode reference to scalar");
              }
  
               if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
                   return 'null';
               }
               else {
                   if ( $type eq 'SCALAR' or $type eq 'REF' ) {
                      encode_error("cannot encode reference to scalar");
                   }
                   else {
                      encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
                   }
               }
  
          }
          else {
              return $self->{fallback}->($value)
                   if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
              return 'null';
          }
  
      }
  
  
      my %esc = (
          "\n" => '\n',
          "\r" => '\r',
          "\t" => '\t',
          "\f" => '\f',
          "\b" => '\b',
          "\"" => '\"',
          "\\" => '\\\\',
          "\'" => '\\\'',
      );
  
  
      sub string_to_json {
          my ($self, $arg) = @_;
  
          $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
          $arg =~ s/\//\\\//g if ($escape_slash);
          $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
  
          if ($ascii) {
              $arg = JSON_PP_encode_ascii($arg);
          }
  
          if ($latin1) {
              $arg = JSON_PP_encode_latin1($arg);
          }
  
          if ($utf8) {
              utf8::encode($arg);
          }
  
          return '"' . $arg . '"';
      }
  
  
      sub blessed_to_json {
          my $reftype = reftype($_[1]) || '';
          if ($reftype eq 'HASH') {
              return $_[0]->hash_to_json($_[1]);
          }
          elsif ($reftype eq 'ARRAY') {
              return $_[0]->array_to_json($_[1]);
          }
          else {
              return 'null';
          }
      }
  
  
      sub encode_error {
          my $error  = shift;
          Carp::croak "$error";
      }
  
  
      sub _sort {
          defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
      }
  
  
      sub _up_indent {
          my $self  = shift;
          my $space = ' ' x $indent_length;
  
          my ($pre,$post) = ('','');
  
          $post = "\n" . $space x $indent_count;
  
          $indent_count++;
  
          $pre = "\n" . $space x $indent_count;
  
          return ($pre,$post);
      }
  
  
      sub _down_indent { $indent_count--; }
  
  
      sub PP_encode_box {
          {
              depth        => $depth,
              indent_count => $indent_count,
          };
      }
  
  } # Convert
  
  
  sub _encode_ascii {
      join('',
          map {
              $_ <= 127 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
          } unpack('U*', $_[0])
      );
  }
  
  
  sub _encode_latin1 {
      join('',
          map {
              $_ <= 255 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
          } unpack('U*', $_[0])
      );
  }
  
  
  sub _encode_surrogates { # from perlunicode
      my $uni = $_[0] - 0x10000;
      return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
  }
  
  
  sub _is_bignum {
      $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
  }
  
  
  
  #
  # JSON => Perl
  #
  
  my $max_intsize;
  
  BEGIN {
      my $checkint = 1111;
      for my $d (5..64) {
          $checkint .= 1;
          my $int   = eval qq| $checkint |;
          if ($int =~ /[eE]/) {
              $max_intsize = $d - 1;
              last;
          }
      }
  }
  
  { # PARSE 
  
      my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
          b    => "\x8",
          t    => "\x9",
          n    => "\xA",
          f    => "\xC",
          r    => "\xD",
          '\\' => '\\',
          '"'  => '"',
          '/'  => '/',
      );
  
      my $text; # json data
      my $at;   # offset
      my $ch;   # 1chracter
      my $len;  # text length (changed according to UTF8 or NON UTF8)
      # INTERNAL
      my $depth;          # nest counter
      my $encoding;       # json text encoding
      my $is_valid_utf8;  # temp variable
      my $utf8_len;       # utf8 byte length
      # FLAGS
      my $utf8;           # must be utf8
      my $max_depth;      # max nest nubmer of objects and arrays
      my $max_size;
      my $relaxed;
      my $cb_object;
      my $cb_sk_object;
  
      my $F_HOOK;
  
      my $allow_bigint;   # using Math::BigInt
      my $singlequote;    # loosely quoting
      my $loose;          # 
      my $allow_barekey;  # bareKey
  
      # $opt flag
      # 0x00000001 .... decode_prefix
      # 0x10000000 .... incr_parse
  
      sub PP_decode_json {
          my ($self, $opt); # $opt is an effective flag during this decode_json.
  
          ($self, $text, $opt) = @_;
  
          ($at, $ch, $depth) = (0, '', 0);
  
          if ( !defined $text or ref $text ) {
              decode_error("malformed JSON string, neither array, object, number, string or atom");
          }
  
          my $idx = $self->{PROPS};
  
          ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
              = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
  
          if ( $utf8 ) {
              utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
          }
          else {
              utf8::upgrade( $text );
          }
  
          $len = length $text;
  
          ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
               = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};
  
          if ($max_size > 1) {
              use bytes;
              my $bytes = length $text;
              decode_error(
                  sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
                      , $bytes, $max_size), 1
              ) if ($bytes > $max_size);
          }
  
          # Currently no effect
          # should use regexp
          my @octets = unpack('C4', $text);
          $encoding =   ( $octets[0] and  $octets[1]) ? 'UTF-8'
                      : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
                      : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
                      : ( $octets[2]                ) ? 'UTF-16LE'
                      : (!$octets[2]                ) ? 'UTF-32LE'
                      : 'unknown';
  
          white(); # remove head white space
  
          my $valid_start = defined $ch; # Is there a first character for JSON structure?
  
          my $result = value();
  
          return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
  
          decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
  
          if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
                  decode_error(
                  'JSON text must be an object or array (but found number, string, true, false or null,'
                         . ' use allow_nonref to allow this)', 1);
          }
  
          Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
  
          my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
  
          white(); # remove tail white space
  
          if ( $ch ) {
              return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
              decode_error("garbage after JSON object");
          }
  
          ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
      }
  
  
      sub next_chr {
          return $ch = undef if($at >= $len);
          $ch = substr($text, $at++, 1);
      }
  
  
      sub value {
          white();
          return          if(!defined $ch);
          return object() if($ch eq '{');
          return array()  if($ch eq '[');
          return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
          return number() if($ch =~ /[0-9]/ or $ch eq '-');
          return word();
      }
  
      sub string {
          my ($i, $s, $t, $u);
          my $utf16;
          my $is_utf8;
  
          ($is_valid_utf8, $utf8_len) = ('', 0);
  
          $s = ''; # basically UTF8 flag on
  
          if($ch eq '"' or ($singlequote and $ch eq "'")){
              my $boundChar = $ch;
  
              OUTER: while( defined(next_chr()) ){
  
                  if($ch eq $boundChar){
                      next_chr();
  
                      if ($utf16) {
                          decode_error("missing low surrogate character in surrogate pair");
                      }
  
                      utf8::decode($s) if($is_utf8);
  
                      return $s;
                  }
                  elsif($ch eq '\\'){
                      next_chr();
                      if(exists $escapes{$ch}){
                          $s .= $escapes{$ch};
                      }
                      elsif($ch eq 'u'){ # UNICODE handling
                          my $u = '';
  
                          for(1..4){
                              $ch = next_chr();
                              last OUTER if($ch !~ /[0-9a-fA-F]/);
                              $u .= $ch;
                          }
  
                          # U+D800 - U+DBFF
                          if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
                              $utf16 = $u;
                          }
                          # U+DC00 - U+DFFF
                          elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
                              unless (defined $utf16) {
                                  decode_error("missing high surrogate character in surrogate pair");
                              }
                              $is_utf8 = 1;
                              $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
                              $utf16 = undef;
                          }
                          else {
                              if (defined $utf16) {
                                  decode_error("surrogate pair expected");
                              }
  
                              if ( ( my $hex = hex( $u ) ) > 127 ) {
                                  $is_utf8 = 1;
                                  $s .= JSON_PP_decode_unicode($u) || next;
                              }
                              else {
                                  $s .= chr $hex;
                              }
                          }
  
                      }
                      else{
                          unless ($loose) {
                              $at -= 2;
                              decode_error('illegal backslash escape sequence in string');
                          }
                          $s .= $ch;
                      }
                  }
                  else{
  
                      if ( ord $ch  > 127 ) {
                          if ( $utf8 ) {
                              unless( $ch = is_valid_utf8($ch) ) {
                                  $at -= 1;
                                  decode_error("malformed UTF-8 character in JSON string");
                              }
                              else {
                                  $at += $utf8_len - 1;
                              }
                          }
                          else {
                              utf8::encode( $ch );
                          }
  
                          $is_utf8 = 1;
                      }
  
                      if (!$loose) {
                          if ($ch =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
                              $at--;
                              decode_error('invalid character encountered while parsing JSON string');
                          }
                      }
  
                      $s .= $ch;
                  }
              }
          }
  
          decode_error("unexpected end of string while parsing JSON string");
      }
  
  
      sub white {
          while( defined $ch  ){
              if($ch le ' '){
                  next_chr();
              }
              elsif($ch eq '/'){
                  next_chr();
                  if(defined $ch and $ch eq '/'){
                      1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
                  }
                  elsif(defined $ch and $ch eq '*'){
                      next_chr();
                      while(1){
                          if(defined $ch){
                              if($ch eq '*'){
                                  if(defined(next_chr()) and $ch eq '/'){
                                      next_chr();
                                      last;
                                  }
                              }
                              else{
                                  next_chr();
                              }
                          }
                          else{
                              decode_error("Unterminated comment");
                          }
                      }
                      next;
                  }
                  else{
                      $at--;
                      decode_error("malformed JSON string, neither array, object, number, string or atom");
                  }
              }
              else{
                  if ($relaxed and $ch eq '#') { # correctly?
                      pos($text) = $at;
                      $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
                      $at = pos($text);
                      next_chr;
                      next;
                  }
  
                  last;
              }
          }
      }
  
  
      sub array {
          my $a  = $_[0] || []; # you can use this code to use another array ref object.
  
          decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                      if (++$depth > $max_depth);
  
          next_chr();
          white();
  
          if(defined $ch and $ch eq ']'){
              --$depth;
              next_chr();
              return $a;
          }
          else {
              while(defined($ch)){
                  push @$a, value();
  
                  white();
  
                  if (!defined $ch) {
                      last;
                  }
  
                  if($ch eq ']'){
                      --$depth;
                      next_chr();
                      return $a;
                  }
  
                  if($ch ne ','){
                      last;
                  }
  
                  next_chr();
                  white();
  
                  if ($relaxed and $ch eq ']') {
                      --$depth;
                      next_chr();
                      return $a;
                  }
  
              }
          }
  
          decode_error(", or ] expected while parsing array");
      }
  
  
      sub object {
          my $o = $_[0] || {}; # you can use this code to use another hash ref object.
          my $k;
  
          decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                  if (++$depth > $max_depth);
          next_chr();
          white();
  
          if(defined $ch and $ch eq '}'){
              --$depth;
              next_chr();
              if ($F_HOOK) {
                  return _json_object_hook($o);
              }
              return $o;
          }
          else {
              while (defined $ch) {
                  $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
                  white();
  
                  if(!defined $ch or $ch ne ':'){
                      $at--;
                      decode_error("':' expected");
                  }
  
                  next_chr();
                  $o->{$k} = value();
                  white();
  
                  last if (!defined $ch);
  
                  if($ch eq '}'){
                      --$depth;
                      next_chr();
                      if ($F_HOOK) {
                          return _json_object_hook($o);
                      }
                      return $o;
                  }
  
                  if($ch ne ','){
                      last;
                  }
  
                  next_chr();
                  white();
  
                  if ($relaxed and $ch eq '}') {
                      --$depth;
                      next_chr();
                      if ($F_HOOK) {
                          return _json_object_hook($o);
                      }
                      return $o;
                  }
  
              }
  
          }
  
          $at--;
          decode_error(", or } expected while parsing object/hash");
      }
  
  
      sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
          my $key;
          while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
              $key .= $ch;
              next_chr();
          }
          return $key;
      }
  
  
      sub word {
          my $word =  substr($text,$at-1,4);
  
          if($word eq 'true'){
              $at += 3;
              next_chr;
              return $JSON::PP::true;
          }
          elsif($word eq 'null'){
              $at += 3;
              next_chr;
              return undef;
          }
          elsif($word eq 'fals'){
              $at += 3;
              if(substr($text,$at,1) eq 'e'){
                  $at++;
                  next_chr;
                  return $JSON::PP::false;
              }
          }
  
          $at--; # for decode_error report
  
          decode_error("'null' expected")  if ($word =~ /^n/);
          decode_error("'true' expected")  if ($word =~ /^t/);
          decode_error("'false' expected") if ($word =~ /^f/);
          decode_error("malformed JSON string, neither array, object, number, string or atom");
      }
  
  
      sub number {
          my $n    = '';
          my $v;
  
          # According to RFC4627, hex or oct digts are invalid.
          if($ch eq '0'){
              my $peek = substr($text,$at,1);
              my $hex  = $peek =~ /[xX]/; # 0 or 1
  
              if($hex){
                  decode_error("malformed number (leading zero must not be followed by another digit)");
                  ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
              }
              else{ # oct
                  ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
                  if (defined $n and length $n > 1) {
                      decode_error("malformed number (leading zero must not be followed by another digit)");
                  }
              }
  
              if(defined $n and length($n)){
                  if (!$hex and length($n) == 1) {
                     decode_error("malformed number (leading zero must not be followed by another digit)");
                  }
                  $at += length($n) + $hex;
                  next_chr;
                  return $hex ? hex($n) : oct($n);
              }
          }
  
          if($ch eq '-'){
              $n = '-';
              next_chr;
              if (!defined $ch or $ch !~ /\d/) {
                  decode_error("malformed number (no digits after initial minus)");
              }
          }
  
          while(defined $ch and $ch =~ /\d/){
              $n .= $ch;
              next_chr;
          }
  
          if(defined $ch and $ch eq '.'){
              $n .= '.';
  
              next_chr;
              if (!defined $ch or $ch !~ /\d/) {
                  decode_error("malformed number (no digits after decimal point)");
              }
              else {
                  $n .= $ch;
              }
  
              while(defined(next_chr) and $ch =~ /\d/){
                  $n .= $ch;
              }
          }
  
          if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
              $n .= $ch;
              next_chr;
  
              if(defined($ch) and ($ch eq '+' or $ch eq '-')){
                  $n .= $ch;
                  next_chr;
                  if (!defined $ch or $ch =~ /\D/) {
                      decode_error("malformed number (no digits after exp sign)");
                  }
                  $n .= $ch;
              }
              elsif(defined($ch) and $ch =~ /\d/){
                  $n .= $ch;
              }
              else {
                  decode_error("malformed number (no digits after exp sign)");
              }
  
              while(defined(next_chr) and $ch =~ /\d/){
                  $n .= $ch;
              }
  
          }
  
          $v .= $n;
  
          if ($v !~ /[.eE]/ and length $v > $max_intsize) {
              if ($allow_bigint) { # from Adam Sussman
                  require Math::BigInt;
                  return Math::BigInt->new($v);
              }
              else {
                  return "$v";
              }
          }
          elsif ($allow_bigint) {
              require Math::BigFloat;
              return Math::BigFloat->new($v);
          }
  
          return 0+$v;
      }
  
  
      sub is_valid_utf8 {
  
          $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
                    : $_[0] =~ /[\xC2-\xDF]/  ? 2
                    : $_[0] =~ /[\xE0-\xEF]/  ? 3
                    : $_[0] =~ /[\xF0-\xF4]/  ? 4
                    : 0
                    ;
  
          return unless $utf8_len;
  
          my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
  
          return ( $is_valid_utf8 =~ /^(?:
               [\x00-\x7F]
              |[\xC2-\xDF][\x80-\xBF]
              |[\xE0][\xA0-\xBF][\x80-\xBF]
              |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
              |[\xED][\x80-\x9F][\x80-\xBF]
              |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
              |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
          )$/x )  ? $is_valid_utf8 : '';
      }
  
  
      sub decode_error {
          my $error  = shift;
          my $no_rep = shift;
          my $str    = defined $text ? substr($text, $at) : '';
          my $mess   = '';
          my $type   = $] >= 5.008           ? 'U*'
                     : $] <  5.006           ? 'C*'
                     : utf8::is_utf8( $str ) ? 'U*' # 5.6
                     : 'C*'
                     ;
  
          for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
              $mess .=  $c == 0x07 ? '\a'
                      : $c == 0x09 ? '\t'
                      : $c == 0x0a ? '\n'
                      : $c == 0x0d ? '\r'
                      : $c == 0x0c ? '\f'
                      : $c <  0x20 ? sprintf('\x{%x}', $c)
                      : $c == 0x5c ? '\\\\'
                      : $c <  0x80 ? chr($c)
                      : sprintf('\x{%x}', $c)
                      ;
              if ( length $mess >= 20 ) {
                  $mess .= '...';
                  last;
              }
          }
  
          unless ( length $mess ) {
              $mess = '(end of string)';
          }
  
          Carp::croak (
              $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
          );
  
      }
  
  
      sub _json_object_hook {
          my $o    = $_[0];
          my @ks = keys %{$o};
  
          if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
              my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
              if (@val == 1) {
                  return $val[0];
              }
          }
  
          my @val = $cb_object->($o) if ($cb_object);
          if (@val == 0 or @val > 1) {
              return $o;
          }
          else {
              return $val[0];
          }
      }
  
  
      sub PP_decode_box {
          {
              text    => $text,
              at      => $at,
              ch      => $ch,
              len     => $len,
              depth   => $depth,
              encoding      => $encoding,
              is_valid_utf8 => $is_valid_utf8,
          };
      }
  
  } # PARSE
  
  
  sub _decode_surrogates { # from perlunicode
      my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
      my $un  = pack('U*', $uni);
      utf8::encode( $un );
      return $un;
  }
  
  
  sub _decode_unicode {
      my $un = pack('U', hex shift);
      utf8::encode( $un );
      return $un;
  }
  
  #
  # Setup for various Perl versions (the code from JSON::PP58)
  #
  
  BEGIN {
  
      unless ( defined &utf8::is_utf8 ) {
         require Encode;
         *utf8::is_utf8 = *Encode::is_utf8;
      }
  
      if ( $] >= 5.008 ) {
          *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
          *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
          *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
          *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
      }
  
      if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
          package JSON::PP;
          require subs;
          subs->import('join');
          eval q|
              sub join {
                  return '' if (@_ < 2);
                  my $j   = shift;
                  my $str = shift;
                  for (@_) { $str .= $j . $_; }
                  return $str;
              }
          |;
      }
  
  
      sub JSON::PP::incr_parse {
          local $Carp::CarpLevel = 1;
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
      }
  
  
      sub JSON::PP::incr_skip {
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
      }
  
  
      sub JSON::PP::incr_reset {
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
      }
  
      eval q{
          sub JSON::PP::incr_text : lvalue {
              $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  
              if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
                  Carp::croak("incr_text can not be called when the incremental parser already started parsing");
              }
              $_[0]->{_incr_parser}->{incr_text};
          }
      } if ( $] >= 5.006 );
  
  } # Setup for various Perl versions (the code from JSON::PP58)
  
  
  ###############################
  # Utilities
  #
  
  BEGIN {
      eval 'require Scalar::Util';
      unless($@){
          *JSON::PP::blessed = \&Scalar::Util::blessed;
          *JSON::PP::reftype = \&Scalar::Util::reftype;
          *JSON::PP::refaddr = \&Scalar::Util::refaddr;
      }
      else{ # This code is from Sclar::Util.
          # warn $@;
          eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
          *JSON::PP::blessed = sub {
              local($@, $SIG{__DIE__}, $SIG{__WARN__});
              ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
          };
          my %tmap = qw(
              B::NULL   SCALAR
              B::HV     HASH
              B::AV     ARRAY
              B::CV     CODE
              B::IO     IO
              B::GV     GLOB
              B::REGEXP REGEXP
          );
          *JSON::PP::reftype = sub {
              my $r = shift;
  
              return undef unless length(ref($r));
  
              my $t = ref(B::svref_2object($r));
  
              return
                  exists $tmap{$t} ? $tmap{$t}
                : length(ref($$r)) ? 'REF'
                :                    'SCALAR';
          };
          *JSON::PP::refaddr = sub {
            return undef unless length(ref($_[0]));
  
            my $addr;
            if(defined(my $pkg = blessed($_[0]))) {
              $addr .= bless $_[0], 'Scalar::Util::Fake';
              bless $_[0], $pkg;
            }
            else {
              $addr .= $_[0]
            }
  
            $addr =~ /0x(\w+)/;
            local $^W;
            #no warnings 'portable';
            hex($1);
          }
      }
  }
  
  
  # shamely copied and modified from JSON::XS code.
  
  $JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
  $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
  
  sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
  
  sub true  { $JSON::PP::true  }
  sub false { $JSON::PP::false }
  sub null  { undef; }
  
  ###############################
  
  package JSON::PP::Boolean;
  
  use overload (
     "0+"     => sub { ${$_[0]} },
     "++"     => sub { $_[0] = ${$_[0]} + 1 },
     "--"     => sub { $_[0] = ${$_[0]} - 1 },
     fallback => 1,
  );
  
  
  ###############################
  
  package JSON::PP::IncrParser;
  
  use strict;
  
  use constant INCR_M_WS   => 0; # initial whitespace skipping
  use constant INCR_M_STR  => 1; # inside string
  use constant INCR_M_BS   => 2; # inside backslash
  use constant INCR_M_JSON => 3; # outside anything, count nesting
  use constant INCR_M_C0   => 4;
  use constant INCR_M_C1   => 5;
  
  $JSON::PP::IncrParser::VERSION = '1.01';
  
  my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
  
  sub new {
      my ( $class ) = @_;
  
      bless {
          incr_nest    => 0,
          incr_text    => undef,
          incr_parsing => 0,
          incr_p       => 0,
      }, $class;
  }
  
  
  sub incr_parse {
      my ( $self, $coder, $text ) = @_;
  
      $self->{incr_text} = '' unless ( defined $self->{incr_text} );
  
      if ( defined $text ) {
          if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
              utf8::upgrade( $self->{incr_text} ) ;
              utf8::decode( $self->{incr_text} ) ;
          }
          $self->{incr_text} .= $text;
      }
  
  
      my $max_size = $coder->get_max_size;
  
      if ( defined wantarray ) {
  
          $self->{incr_mode} = INCR_M_WS;
  
          if ( wantarray ) {
              my @ret;
  
              $self->{incr_parsing} = 1;
  
              do {
                  push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
  
                  unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
                      $self->{incr_mode} = INCR_M_WS;
                  }
  
              } until ( !$self->{incr_text} );
  
              $self->{incr_parsing} = 0;
  
              return @ret;
          }
          else { # in scalar context
              $self->{incr_parsing} = 1;
              my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
              $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
              return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
          }
  
      }
  
  }
  
  
  sub _incr_parse {
      my ( $self, $coder, $text, $skip ) = @_;
      my $p = $self->{incr_p};
      my $restore = $p;
  
      my @obj;
      my $len = length $text;
  
      if ( $self->{incr_mode} == INCR_M_WS ) {
          while ( $len > $p ) {
              my $s = substr( $text, $p, 1 );
              $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
              $self->{incr_mode} = INCR_M_JSON;
              last;
         }
      }
  
      while ( $len > $p ) {
          my $s = substr( $text, $p++, 1 );
  
          if ( $s eq '"' ) {
              if ( $self->{incr_mode} != INCR_M_STR  ) {
                  $self->{incr_mode} = INCR_M_STR;
              }
              else {
                  $self->{incr_mode} = INCR_M_JSON;
                  unless ( $self->{incr_nest} ) {
                      last;
                  }
              }
          }
  
          if ( $self->{incr_mode} == INCR_M_JSON ) {
  
              if ( $s eq '[' or $s eq '{' ) {
                  if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
                      Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
                  }
              }
              elsif ( $s eq ']' or $s eq '}' ) {
                  last if ( --$self->{incr_nest} <= 0 );
              }
              elsif ( $s eq '#' ) {
                  while ( $len > $p ) {
                      last if substr( $text, $p++, 1 ) eq "\n";
                  }
              }
  
          }
  
      }
  
      $self->{incr_p} = $p;
  
      return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
  
      return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
  
      local $Carp::CarpLevel = 2;
  
      $self->{incr_p} = $restore;
      $self->{incr_c} = $p;
  
      my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
  
      $self->{incr_text} = substr( $self->{incr_text}, $p );
      $self->{incr_p} = 0;
  
      return $obj or '';
  }
  
  
  sub incr_text {
      if ( $_[0]->{incr_parsing} ) {
          Carp::croak("incr_text can not be called when the incremental parser already started parsing");
      }
      $_[0]->{incr_text};
  }
  
  
  sub incr_skip {
      my $self  = shift;
      $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
      $self->{incr_p} = 0;
  }
  
  
  sub incr_reset {
      my $self = shift;
      $self->{incr_text}    = undef;
      $self->{incr_p}       = 0;
      $self->{incr_mode}    = 0;
      $self->{incr_nest}    = 0;
      $self->{incr_parsing} = 0;
  }
  
  ###############################
  
  
  1;
  __END__
  =pod
  
  =head1 NAME
  
  JSON::PP - JSON::XS compatible pure-Perl module.
  
  =head1 SYNOPSIS
  
   use JSON::PP;
  
   # exported functions, they croak on error
   # and expect/generate UTF-8
  
   $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
   $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
  
   # OO-interface
  
   $coder = JSON::PP->new->ascii->pretty->allow_nonref;
   
   $json_text   = $json->encode( $perl_scalar );
   $perl_scalar = $json->decode( $json_text );
   
   $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
   
   # Note that JSON version 2.0 and above will automatically use
   # JSON::XS or JSON::PP, so you should be able to just:
   
   use JSON;
  
  
  =head1 VERSION
  
      2.27103
  
  =head1 NOTE
  
  JSON::PP was inculded in JSON distribution (CPAN module).
  It comes to be a perl core module in Perl 5.14.
  
      [STEPS]
  
      * release this module as JSON::PPdev.
  
      * release other PP::* modules as JSON::PP::Compat*.
  
      * JSON distribution will inculde yet another JSON::PP modules.
        They are JSNO::backportPP. So JSON.pm should work as it did at all!
  
      * remove JSON::PP and JSON::PP::* modules from JSON distribution
         and release it as developer version.
  
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
      * release JSON distribution as stable version.
  
      * rename JSON::PPdev into JSON::PP and release on CPAN. <<<< HERE
  
  =head1 DESCRIPTION
  
  This module is L<JSON::XS> compatible pure Perl module.
  (Perl 5.8 or later is recommended)
  
  JSON::XS is the fastest and most proper JSON module on CPAN.
  It is written by Marc Lehmann in C, so must be compiled and
  installed in the used environment.
  
  JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
  
  
  =head2 FEATURES
  
  =over
  
  =item * correct unicode handling
  
  This module knows how to handle Unicode (depending on Perl version).
  
  See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
  
  
  =item * round-trip integrity
  
  When you serialise a perl data structure using only data types supported
  by JSON and Perl, the deserialised data structure is identical on the Perl
  level. (e.g. the string "2.0" doesn't suddenly become "2" just because
  it looks like a number). There I<are> minor exceptions to this, read the
  MAPPING section below to learn about those.
  
  
  =item * strict checking of JSON correctness
  
  There is no guessing, no generating of illegal JSON texts by default,
  and only JSON is accepted as input by default (the latter is a security feature).
  But when some options are set, loose chcking features are available.
  
  =back
  
  =head1 FUNCTIONAL INTERFACE
  
  Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
  
  =head2 encode_json
  
      $json_text = encode_json $perl_scalar
  
  Converts the given Perl data structure to a UTF-8 encoded, binary string.
  
  This function call is functionally identical to:
  
      $json_text = JSON::PP->new->utf8->encode($perl_scalar)
  
  =head2 decode_json
  
      $perl_scalar = decode_json $json_text
  
  The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
  to parse that as an UTF-8 encoded JSON text, returning the resulting
  reference.
  
  This function call is functionally identical to:
  
      $perl_scalar = JSON::PP->new->utf8->decode($json_text)
  
  =head2 JSON::PP::is_bool
  
      $is_boolean = JSON::PP::is_bool($scalar)
  
  Returns true if the passed scalar represents either JSON::PP::true or
  JSON::PP::false, two constants that act like C<1> and C<0> respectively
  and are also used to represent JSON C<true> and C<false> in Perl strings.
  
  =head2 JSON::PP::true
  
  Returns JSON true value which is blessed object.
  It C<isa> JSON::PP::Boolean object.
  
  =head2 JSON::PP::false
  
  Returns JSON false value which is blessed object.
  It C<isa> JSON::PP::Boolean object.
  
  =head2 JSON::PP::null
  
  Returns C<undef>.
  
  See L<MAPPING>, below, for more information on how JSON values are mapped to
  Perl.
  
  
  =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
  
  This section supposes that your perl vresion is 5.8 or later.
  
  If you know a JSON text from an outer world - a network, a file content, and so on,
  is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
  with C<utf8> enable. And the decoded result will contain UNICODE characters.
  
    # from network
    my $json        = JSON::PP->new->utf8;
    my $json_text   = CGI->new->param( 'json_data' );
    my $perl_scalar = $json->decode( $json_text );
    
    # from file content
    local $/;
    open( my $fh, '<', 'json.data' );
    $json_text   = <$fh>;
    $perl_scalar = decode_json( $json_text );
  
  If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
  
    use Encode;
    local $/;
    open( my $fh, '<', 'json.data' );
    my $encoding = 'cp932';
    my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
    
    # or you can write the below code.
    #
    # open( my $fh, "<:encoding($encoding)", 'json.data' );
    # $unicode_json_text = <$fh>;
  
  In this case, C<$unicode_json_text> is of course UNICODE string.
  So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
  Instead of them, you use C<JSON> module object with C<utf8> disable.
  
    $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
  
  Or C<encode 'utf8'> and C<decode_json>:
  
    $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
    # this way is not efficient.
  
  And now, you want to convert your C<$perl_scalar> into JSON data and
  send it to an outer world - a network or a file content, and so on.
  
  Your data usually contains UNICODE strings and you want the converted data to be encoded
  in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
  
    print encode_json( $perl_scalar ); # to a network? file? or display?
    # or
    print $json->utf8->encode( $perl_scalar );
  
  If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
  for some reason, then its characters are regarded as B<latin1> for perl
  (because it does not concern with your $encoding).
  You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
  Instead of them, you use C<JSON> module object with C<utf8> disable.
  Note that the resulted text is a UNICODE string but no problem to print it.
  
    # $perl_scalar contains $encoding encoded string values
    $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
    # $unicode_json_text consists of characters less than 0x100
    print $unicode_json_text;
  
  Or C<decode $encoding> all string values and C<encode_json>:
  
    $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
    # ... do it to each string values, then encode_json
    $json_text = encode_json( $perl_scalar );
  
  This method is a proper way but probably not efficient.
  
  See to L<Encode>, L<perluniintro>.
  
  
  =head1 METHODS
  
  Basically, check to L<JSON> or L<JSON::XS>.
  
  =head2 new
  
      $json = new JSON::PP
  
  Rturns a new JSON::PP object that can be used to de/encode JSON
  strings.
  
  All boolean flags described below are by default I<disabled>.
  
  The mutators for flags all return the JSON object again and thus calls can
  be chained:
  
     my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
     => {"a": [1, 2]}
  
  =head2 ascii
  
      $json = $json->ascii([$enable])
      
      $enabled = $json->get_ascii
  
  If $enable is true (or missing), then the encode method will not generate characters outside
  the code range 0..127. Any Unicode characters outside that range will be escaped using either
  a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
  (See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
  
  In Perl 5.005, there is no character having high value (more than 255).
  See to L<UNICODE HANDLING ON PERLS>.
  
  If $enable is false, then the encode method will not escape Unicode characters unless
  required by the JSON syntax or other flags. This results in a faster and more compact format.
  
    JSON::PP->new->ascii(1)->encode([chr 0x10401])
    => ["\ud801\udc01"]
  
  =head2 latin1
  
      $json = $json->latin1([$enable])
      
      $enabled = $json->get_latin1
  
  If $enable is true (or missing), then the encode method will encode the resulting JSON
  text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
  
  If $enable is false, then the encode method will not escape Unicode characters
  unless required by the JSON syntax or other flags.
  
    JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  See to L<UNICODE HANDLING ON PERLS>.
  
  =head2 utf8
  
      $json = $json->utf8([$enable])
      
      $enabled = $json->get_utf8
  
  If $enable is true (or missing), then the encode method will encode the JSON result
  into UTF-8, as required by many protocols, while the decode method expects to be handled
  an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
  characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
  
  (In Perl 5.005, any character outside the range 0..255 does not exist.
  See to L<UNICODE HANDLING ON PERLS>.)
  
  In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
  encoding families, as described in RFC4627.
  
  If $enable is false, then the encode method will return the JSON string as a (non-encoded)
  Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
  (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
  
  Example, output UTF-16BE-encoded JSON:
  
    use Encode;
    $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
  
  Example, decode UTF-32LE-encoded JSON:
  
    use Encode;
    $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
  
  
  =head2 pretty
  
      $json = $json->pretty([$enable])
  
  This enables (or disables) all of the C<indent>, C<space_before> and
  C<space_after> flags in one call to generate the most readable
  (or most compact) form possible.
  
  Equivalent to:
  
     $json->indent->space_before->space_after
  
  =head2 indent
  
      $json = $json->indent([$enable])
      
      $enabled = $json->get_indent
  
  The default indent space length is three.
  You can use C<indent_length> to change the length.
  
  =head2 space_before
  
      $json = $json->space_before([$enable])
      
      $enabled = $json->get_space_before
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space before the C<:> separating keys from values in JSON objects.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before enabled, space_after and indent disabled:
  
     {"key" :"value"}
  
  =head2 space_after
  
      $json = $json->space_after([$enable])
      
      $enabled = $json->get_space_after
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space after the C<:> separating keys from values in JSON objects
  and extra whitespace after the C<,> separating key-value pairs and array
  members.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before and indent disabled, space_after enabled:
  
     {"key": "value"}
  
  =head2 relaxed
  
      $json = $json->relaxed([$enable])
      
      $enabled = $json->get_relaxed
  
  If C<$enable> is true (or missing), then C<decode> will accept some
  extensions to normal JSON syntax (see below). C<encode> will not be
  affected in anyway. I<Be aware that this option makes you accept invalid
  JSON texts as if they were valid!>. I suggest only to use this option to
  parse application-specific files written by humans (configuration files,
  resource files etc.)
  
  If C<$enable> is false (the default), then C<decode> will only accept
  valid JSON texts.
  
  Currently accepted extensions are:
  
  =over 4
  
  =item * list items can have an end-comma
  
  JSON I<separates> array elements and key-value pairs with commas. This
  can be annoying if you write JSON texts manually and want to be able to
  quickly append elements, so this extension accepts comma at the end of
  such items not just between them:
  
     [
        1,
        2, <- this comma not normally allowed
     ]
     {
        "k1": "v1",
        "k2": "v2", <- this comma not normally allowed
     }
  
  =item * shell-style '#'-comments
  
  Whenever JSON allows whitespace, shell-style comments are additionally
  allowed. They are terminated by the first carriage-return or line-feed
  character, after which more white-space and comments are allowed.
  
    [
       1, # this comment not allowed in JSON
          # neither this one...
    ]
  
  =back
  
  =head2 canonical
  
      $json = $json->canonical([$enable])
      
      $enabled = $json->get_canonical
  
  If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
  by sorting their keys. This is adding a comparatively high overhead.
  
  If C<$enable> is false, then the C<encode> method will output key-value
  pairs in the order Perl stores them (which will likely change between runs
  of the same script).
  
  This option is useful if you want the same data structure to be encoded as
  the same JSON text (given the same overall settings). If it is disabled,
  the same hash might be encoded differently even if contains the same data,
  as key-value pairs have no inherent ordering in Perl.
  
  This setting has no effect when decoding JSON texts.
  
  If you want your own sorting routine, you can give a code referece
  or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
  
  =head2 allow_nonref
  
      $json = $json->allow_nonref([$enable])
      
      $enabled = $json->get_allow_nonref
  
  If C<$enable> is true (or missing), then the C<encode> method can convert a
  non-reference into its corresponding string, number or null JSON value,
  which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
  values instead of croaking.
  
  If C<$enable> is false, then the C<encode> method will croak if it isn't
  passed an arrayref or hashref, as JSON texts must either be an object
  or array. Likewise, C<decode> will croak if given something that is not a
  JSON object or array.
  
     JSON::PP->new->allow_nonref->encode ("Hello, World!")
     => "Hello, World!"
  
  =head2 allow_unknown
  
      $json = $json->allow_unknown ([$enable])
      
      $enabled = $json->get_allow_unknown
  
  If $enable is true (or missing), then "encode" will *not* throw an
  exception when it encounters values it cannot represent in JSON (for
  example, filehandles) but instead will encode a JSON "null" value.
  Note that blessed objects are not included here and are handled
  separately by c<allow_nonref>.
  
  If $enable is false (the default), then "encode" will throw an
  exception when it encounters anything it cannot encode as JSON.
  
  This option does not affect "decode" in any way, and it is
  recommended to leave it off unless you know your communications
  partner.
  
  =head2 allow_blessed
  
      $json = $json->allow_blessed([$enable])
      
      $enabled = $json->get_allow_blessed
  
  If C<$enable> is true (or missing), then the C<encode> method will not
  barf when it encounters a blessed reference. Instead, the value of the
  B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
  disabled or no C<TO_JSON> method found) or a representation of the
  object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
  encoded. Has no effect on C<decode>.
  
  If C<$enable> is false (the default), then C<encode> will throw an
  exception when it encounters a blessed object.
  
  =head2 convert_blessed
  
      $json = $json->convert_blessed([$enable])
      
      $enabled = $json->get_convert_blessed
  
  If C<$enable> is true (or missing), then C<encode>, upon encountering a
  blessed object, will check for the availability of the C<TO_JSON> method
  on the object's class. If found, it will be called in scalar context
  and the resulting scalar will be encoded instead of the object. If no
  C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
  to do.
  
  The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
  returns other blessed objects, those will be handled in the same
  way. C<TO_JSON> must take care of not causing an endless recursion cycle
  (== crash) in this case. The name of C<TO_JSON> was chosen because other
  methods called by the Perl core (== not by the user of the object) are
  usually in upper case letters and to avoid collisions with the C<to_json>
  function or method.
  
  This setting does not yet influence C<decode> in any way.
  
  If C<$enable> is false, then the C<allow_blessed> setting will decide what
  to do when a blessed object is found.
  
  =head2 filter_json_object
  
      $json = $json->filter_json_object([$coderef])
  
  When C<$coderef> is specified, it will be called from C<decode> each
  time it decodes a JSON object. The only argument passed to the coderef
  is a reference to the newly-created hash. If the code references returns
  a single scalar (which need not be a reference), this value
  (i.e. a copy of that scalar to avoid aliasing) is inserted into the
  deserialised data structure. If it returns an empty list
  (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
  hash will be inserted. This setting can slow down decoding considerably.
  
  When C<$coderef> is omitted or undefined, any existing callback will
  be removed and C<decode> will not change the deserialised hash in any
  way.
  
  Example, convert all JSON objects into the integer 5:
  
     my $js = JSON::PP->new->filter_json_object (sub { 5 });
     # returns [5]
     $js->decode ('[{}]'); # the given subroutine takes a hash reference.
     # throw an exception because allow_nonref is not enabled
     # so a lone 5 is not allowed.
     $js->decode ('{"a":1, "b":2}');
  
  =head2 filter_json_single_key_object
  
      $json = $json->filter_json_single_key_object($key [=> $coderef])
  
  Works remotely similar to C<filter_json_object>, but is only called for
  JSON objects having a single key named C<$key>.
  
  This C<$coderef> is called before the one specified via
  C<filter_json_object>, if any. It gets passed the single value in the JSON
  object. If it returns a single value, it will be inserted into the data
  structure. If it returns nothing (not even C<undef> but the empty list),
  the callback from C<filter_json_object> will be called next, as if no
  single-key callback were specified.
  
  If C<$coderef> is omitted or undefined, the corresponding callback will be
  disabled. There can only ever be one callback for a given key.
  
  As this callback gets called less often then the C<filter_json_object>
  one, decoding speed will not usually suffer as much. Therefore, single-key
  objects make excellent targets to serialise Perl objects into, especially
  as single-key JSON objects are as close to the type-tagged value concept
  as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
  support this in any way, so you need to make sure your data never looks
  like a serialised Perl hash.
  
  Typical names for the single object key are C<__class_whatever__>, or
  C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
  things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
  with real hashes.
  
  Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
  into the corresponding C<< $WIDGET{<id>} >> object:
  
     # return whatever is in $WIDGET{5}:
     JSON::PP
        ->new
        ->filter_json_single_key_object (__widget__ => sub {
              $WIDGET{ $_[0] }
           })
        ->decode ('{"__widget__": 5')
  
     # this can be used with a TO_JSON method in some "widget" class
     # for serialisation to json:
     sub WidgetBase::TO_JSON {
        my ($self) = @_;
  
        unless ($self->{id}) {
           $self->{id} = ..get..some..id..;
           $WIDGET{$self->{id}} = $self;
        }
  
        { __widget__ => $self->{id} }
     }
  
  =head2 shrink
  
      $json = $json->shrink([$enable])
      
      $enabled = $json->get_shrink
  
  In JSON::XS, this flag resizes strings generated by either
  C<encode> or C<decode> to their minimum size possible.
  It will also try to downgrade any strings to octet-form if possible.
  
  In JSON::PP, it is noop about resizing strings but tries
  C<utf8::downgrade> to the returned string by C<encode>.
  See to L<utf8>.
  
  See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
  
  =head2 max_depth
  
      $json = $json->max_depth([$maximum_nesting_depth])
      
      $max_depth = $json->get_max_depth
  
  Sets the maximum nesting level (default C<512>) accepted while encoding
  or decoding. If a higher nesting level is detected in JSON text or a Perl
  data structure, then the encoder and decoder will stop and croak at that
  point.
  
  Nesting level is defined by number of hash- or arrayrefs that the encoder
  needs to traverse to reach a given point or the number of C<{> or C<[>
  characters without their matching closing parenthesis crossed to reach a
  given character in a string.
  
  If no argument is given, the highest possible setting will be used, which
  is rarely useful.
  
  See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
  
  When a large value (100 or more) was set and it de/encodes a deep nested object/text,
  it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
  
  =head2 max_size
  
      $json = $json->max_size([$maximum_string_size])
      
      $max_size = $json->get_max_size
  
  Set the maximum length a JSON text may have (in bytes) where decoding is
  being attempted. The default is C<0>, meaning no limit. When C<decode>
  is called on a string that is longer then this many bytes, it will not
  attempt to decode the string but throw an exception. This setting has no
  effect on C<encode> (yet).
  
  If no argument is given, the limit check will be deactivated (same as when
  C<0> is specified).
  
  See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
  
  =head2 encode
  
      $json_text = $json->encode($perl_scalar)
  
  Converts the given Perl data structure (a simple scalar or a reference
  to a hash or array) to its JSON representation. Simple scalars will be
  converted into JSON string or number sequences, while references to arrays
  become JSON arrays and references to hashes become JSON objects. Undefined
  Perl values (e.g. C<undef>) become JSON C<null> values.
  References to the integers C<0> and C<1> are converted into C<true> and C<false>.
  
  =head2 decode
  
      $perl_scalar = $json->decode($json_text)
  
  The opposite of C<encode>: expects a JSON text and tries to parse it,
  returning the resulting simple scalar or reference. Croaks on error.
  
  JSON numbers and strings become simple Perl scalars. JSON arrays become
  Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
  C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
  C<null> becomes C<undef>.
  
  =head2 decode_prefix
  
      ($perl_scalar, $characters) = $json->decode_prefix($json_text)
  
  This works like the C<decode> method, but instead of raising an exception
  when there is trailing garbage after the first JSON object, it will
  silently stop parsing there and return the number of characters consumed
  so far.
  
     JSON->new->decode_prefix ("[1] the tail")
     => ([], 3)
  
  =head1 INCREMENTAL PARSING
  
  Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
  
  In some cases, there is the need for incremental parsing of JSON texts.
  This module does allow you to parse a JSON stream incrementally.
  It does so by accumulating text until it has a full JSON object, which
  it then can decode. This process is similar to using C<decode_prefix>
  to see if a full JSON object is available, but is much more efficient
  (and can be implemented with a minimum of method calls).
  
  This module will only attempt to parse the JSON text once it is sure it
  has enough text to get a decisive result, using a very simple but
  truly incremental parser. This means that it sometimes won't stop as
  early as the full parser, for example, it doesn't detect parenthese
  mismatches. The only thing it guarantees is that it starts decoding as
  soon as a syntactically valid JSON text has been seen. This means you need
  to set resource limits (e.g. C<max_size>) to ensure the parser will stop
  parsing in the presence if syntax errors.
  
  The following methods implement this incremental parser.
  
  =head2 incr_parse
  
      $json->incr_parse( [$string] ) # void context
      
      $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
      
      @obj_or_empty = $json->incr_parse( [$string] ) # list context
  
  This is the central parsing function. It can both append new text and
  extract objects from the stream accumulated so far (both of these
  functions are optional).
  
  If C<$string> is given, then this string is appended to the already
  existing JSON fragment stored in the C<$json> object.
  
  After that, if the function is called in void context, it will simply
  return without doing anything further. This can be used to add more text
  in as many chunks as you want.
  
  If the method is called in scalar context, then it will try to extract
  exactly I<one> JSON object. If that is successful, it will return this
  object, otherwise it will return C<undef>. If there is a parse error,
  this method will croak just as C<decode> would do (one can then use
  C<incr_skip> to skip the errornous part). This is the most common way of
  using the method.
  
  And finally, in list context, it will try to extract as many objects
  from the stream as it can find and return them, or the empty list
  otherwise. For this to work, there must be no separators between the JSON
  objects or arrays, instead they must be concatenated back-to-back. If
  an error occurs, an exception will be raised as in the scalar context
  case. Note that in this case, any previously-parsed JSON texts will be
  lost.
  
  Example: Parse some JSON arrays/objects in a given string and return them.
  
      my @objs = JSON->new->incr_parse ("[5][7][1,2]");
  
  =head2 incr_text
  
      $lvalue_string = $json->incr_text
  
  This method returns the currently stored JSON fragment as an lvalue, that
  is, you can manipulate it. This I<only> works when a preceding call to
  C<incr_parse> in I<scalar context> successfully returned an object. Under
  all other circumstances you must not call this function (I mean it.
  although in simple tests it might actually work, it I<will> fail under
  real world conditions). As a special exception, you can also call this
  method before having parsed anything.
  
  This function is useful in two cases: a) finding the trailing text after a
  JSON object or b) parsing multiple JSON objects separated by non-JSON text
  (such as commas).
  
      $json->incr_text =~ s/\s*,\s*//;
  
  In Perl 5.005, C<lvalue> attribute is not available.
  You must write codes like the below:
  
      $string = $json->incr_text;
      $string =~ s/\s*,\s*//;
      $json->incr_text( $string );
  
  =head2 incr_skip
  
      $json->incr_skip
  
  This will reset the state of the incremental parser and will remove the
  parsed text from the input buffer. This is useful after C<incr_parse>
  died, in which case the input buffer and incremental parser state is left
  unchanged, to skip the text parsed so far and to reset the parse state.
  
  =head2 incr_reset
  
      $json->incr_reset
  
  This completely resets the incremental parser, that is, after this call,
  it will be as if the parser had never parsed anything.
  
  This is useful if you want ot repeatedly parse JSON objects and want to
  ignore any trailing data, which means you have to reset the parser after
  each successful decode.
  
  See to L<JSON::XS/INCREMENTAL PARSING> for examples.
  
  
  =head1 JSON::PP OWN METHODS
  
  =head2 allow_singlequote
  
      $json = $json->allow_singlequote([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  JSON strings quoted by single quotations that are invalid JSON
  format.
  
      $json->allow_singlequote->decode({"foo":'bar'});
      $json->allow_singlequote->decode({'foo':"bar"});
      $json->allow_singlequote->decode({'foo':'bar'});
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
  
  =head2 allow_barekey
  
      $json = $json->allow_barekey([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  bare keys of JSON object that are invalid JSON format.
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
      $json->allow_barekey->decode('{foo:"bar"}');
  
  =head2 allow_bignum
  
      $json = $json->allow_bignum([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will convert
  the big integer Perl cannot handle as integer into a L<Math::BigInt>
  object and convert a floating number (any) into a L<Math::BigFloat>.
  
  On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
  objects into JSON numbers with C<allow_blessed> enable.
  
     $json->allow_nonref->allow_blessed->allow_bignum;
     $bigfloat = $json->decode('2.000000000000000000000000001');
     print $json->encode($bigfloat);
     # => 2.000000000000000000000000001
  
  See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
  
  =head2 loose
  
      $json = $json->loose([$enable])
  
  The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
  and the module doesn't allow to C<decode> to these (except for \x2f).
  If C<$enable> is true (or missing), then C<decode>  will accept these
  unescaped strings.
  
      $json->loose->decode(qq|["abc
                                     def"]|);
  
  See L<JSON::XS/SSECURITY CONSIDERATIONS>.
  
  =head2 escape_slash
  
      $json = $json->escape_slash([$enable])
  
  According to JSON Grammar, I<slash> (U+002F) is escaped. But default
  JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
  
  If C<$enable> is true (or missing), then C<encode> will escape slashes.
  
  =head2 indent_length
  
      $json = $json->indent_length($length)
  
  JSON::XS indent space length is 3 and cannot be changed.
  JSON::PP set the indent space length with the given $length.
  The default is 3. The acceptable range is 0 to 15.
  
  =head2 sort_by
  
      $json = $json->sort_by($function_name)
      $json = $json->sort_by($subroutine_ref)
  
  If $function_name or $subroutine_ref are set, its sort routine are used
  in encoding JSON objects.
  
     $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     $js = $pc->sort_by('own_sort')->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
  
  As the sorting routine runs in the JSON::PP scope, the given
  subroutine name and the special variables C<$a>, C<$b> will begin
  'JSON::PP::'.
  
  If $integer is set, then the effect is same as C<canonical> on.
  
  =head1 INTERNAL
  
  For developers.
  
  =over
  
  =item PP_encode_box
  
  Returns
  
          {
              depth        => $depth,
              indent_count => $indent_count,
          }
  
  
  =item PP_decode_box
  
  Returns
  
          {
              text    => $text,
              at      => $at,
              ch      => $ch,
              len     => $len,
              depth   => $depth,
              encoding      => $encoding,
              is_valid_utf8 => $is_valid_utf8,
          };
  
  =back
  
  =head1 MAPPING
  
  This section is copied from JSON::XS and modified to C<JSON::PP>.
  JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
  
  See to L<JSON::XS/MAPPING>.
  
  =head2 JSON -> PERL
  
  =over 4
  
  =item object
  
  A JSON object becomes a reference to a hash in Perl. No ordering of object
  keys is preserved (JSON does not preserver object key ordering itself).
  
  =item array
  
  A JSON array becomes a reference to an array in Perl.
  
  =item string
  
  A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
  are represented by the same codepoints in the Perl string, so no manual
  decoding is necessary.
  
  =item number
  
  A JSON number becomes either an integer, numeric (floating point) or
  string scalar in perl, depending on its range and any fractional parts. On
  the Perl level, there is no difference between those as Perl handles all
  the conversion details, but an integer may take slightly less memory and
  might represent more values exactly than floating point numbers.
  
  If the number consists of digits only, C<JSON> will try to represent
  it as an integer value. If that fails, it will try to represent it as
  a numeric (floating point) value if that is possible without loss of
  precision. Otherwise it will preserve the number as a string value (in
  which case you lose roundtripping ability, as the JSON number will be
  re-encoded toa JSON string).
  
  Numbers containing a fractional or exponential part will always be
  represented as numeric (floating point) values, possibly at a loss of
  precision (in which case you might lose perfect roundtripping ability, but
  the JSON number will still be re-encoded as a JSON number).
  
  Note that precision is not accuracy - binary floating point values cannot
  represent most decimal fractions exactly, and when converting from and to
  floating point, C<JSON> only guarantees precision up to but not including
  the leats significant bit.
  
  When C<allow_bignum> is enable, the big integers 
  and the numeric can be optionally converted into L<Math::BigInt> and
  L<Math::BigFloat> objects.
  
  =item true, false
  
  These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
  respectively. They are overloaded to act almost exactly like the numbers
  C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
  the C<JSON::is_bool> function.
  
     print JSON::PP::true . "\n";
      => true
     print JSON::PP::true + 1;
      => 1
  
     ok(JSON::true eq  '1');
     ok(JSON::true == 1);
  
  C<JSON> will install these missing overloading features to the backend modules.
  
  
  =item null
  
  A JSON null atom becomes C<undef> in Perl.
  
  C<JSON::PP::null> returns C<unddef>.
  
  =back
  
  
  =head2 PERL -> JSON
  
  The mapping from Perl to JSON is slightly more difficult, as Perl is a
  truly typeless language, so we can only guess which JSON type is meant by
  a Perl value.
  
  =over 4
  
  =item hash references
  
  Perl hash references become JSON objects. As there is no inherent ordering
  in hash keys (or JSON objects), they will usually be encoded in a
  pseudo-random order that can change between runs of the same program but
  stays generally the same within a single run of a program. C<JSON>
  optionally sort the hash keys (determined by the I<canonical> flag), so
  the same datastructure will serialise to the same JSON text (given same
  settings and version of JSON::XS), but this incurs a runtime overhead
  and is only rarely useful, e.g. when you want to compare some JSON text
  against another for equality.
  
  
  =item array references
  
  Perl array references become JSON arrays.
  
  =item other references
  
  Other unblessed references are generally not allowed and will cause an
  exception to be thrown, except for references to the integers C<0> and
  C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
  also use C<JSON::false> and C<JSON::true> to improve readability.
  
     to_json [\0,JSON::PP::true]      # yields [false,true]
  
  =item JSON::PP::true, JSON::PP::false, JSON::PP::null
  
  These special values become JSON true and JSON false values,
  respectively. You can also use C<\1> and C<\0> directly if you want.
  
  JSON::PP::null returns C<undef>.
  
  =item blessed objects
  
  Blessed objects are not directly representable in JSON. See the
  C<allow_blessed> and C<convert_blessed> methods on various options on
  how to deal with this: basically, you can choose between throwing an
  exception, encoding the reference as if it weren't blessed, or provide
  your own serialiser method.
  
  See to L<convert_blessed>.
  
  =item simple scalars
  
  Simple Perl scalars (any scalar that is not a reference) are the most
  difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
  JSON C<null> values, scalars that have last been used in a string context
  before encoding as JSON strings, and anything else as number value:
  
     # dump as number
     encode_json [2]                      # yields [2]
     encode_json [-3.0e17]                # yields [-3e+17]
     my $value = 5; encode_json [$value]  # yields [5]
  
     # used as string, so dump as string
     print $value;
     encode_json [$value]                 # yields ["5"]
  
     # undef becomes null
     encode_json [undef]                  # yields [null]
  
  You can force the type to be a string by stringifying it:
  
     my $x = 3.1; # some variable containing a number
     "$x";        # stringified
     $x .= "";    # another, more awkward way to stringify
     print $x;    # perl does it for you, too, quite often
  
  You can force the type to be a number by numifying it:
  
     my $x = "3"; # some variable containing a string
     $x += 0;     # numify it, ensuring it will be dumped as a number
     $x *= 1;     # same thing, the choise is yours.
  
  You can not currently force the type in other, less obscure, ways.
  
  Note that numerical precision has the same meaning as under Perl (so
  binary to decimal conversion follows the same rules as in Perl, which
  can differ to other languages). Also, your perl interpreter might expose
  extensions to the floating point numbers of your platform, such as
  infinities or NaN's - these cannot be represented in JSON, and it is an
  error to pass those in.
  
  =item Big Number
  
  When C<allow_bignum> is enable, 
  C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
  objects into JSON numbers.
  
  
  =back
  
  =head1 UNICODE HANDLING ON PERLS
  
  If you do not know about Unicode on Perl well,
  please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
  
  =head2 Perl 5.8 and later
  
  Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
  
      $json->allow_nonref->encode(chr hex 3042);
      $json->allow_nonref->encode(chr hex 12345);
  
  Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
  
      $json->allow_nonref->decode('"\u3042"');
      $json->allow_nonref->decode('"\ud808\udf45"');
  
  Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
  
  Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
  so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
  
  
  =head2 Perl 5.6
  
  Perl can handle Unicode and the JSON::PP de/encode methods also work.
  
  =head2 Perl 5.005
  
  Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
  That means the unicode handling is not available.
  
  In encoding,
  
      $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
      $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
  
  Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
  as C<$value % 256>, so the above codes are equivalent to :
  
      $json->allow_nonref->encode(chr 66);
      $json->allow_nonref->encode(chr 69);
  
  In decoding,
  
      $json->decode('"\u00e3\u0081\u0082"');
  
  The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
  japanese character (C<HIRAGANA LETTER A>).
  And if it is represented in Unicode code point, C<U+3042>.
  
  Next, 
  
      $json->decode('"\u3042"');
  
  We ordinary expect the returned value is a Unicode character C<U+3042>.
  But here is 5.005 world. This is C<0xE3 0x81 0x82>.
  
      $json->decode('"\ud808\udf45"');
  
  This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
  
  
  =head1 TODO
  
  =over
  
  =item speed
  
  =item memory saving
  
  =back
  
  
  =head1 SEE ALSO
  
  Most of the document are copied and modified from JSON::XS doc.
  
  L<JSON::XS>
  
  RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2010 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
JSON_PP

$fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN';
  =head1 NAME
  
  JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
  
  =head1 SYNOPSIS
  
   # do not "use" yourself
  
  =head1 DESCRIPTION
  
  This module exists only to provide overload resolution for Storable and similar modules. See
  L<JSON::PP> for more info about this class.
  
  =cut
  
  use JSON::PP ();
  use strict;
  
  1;
  
  =head1 AUTHOR
  
  This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
  
  =cut
  
JSON_PP_BOOLEAN

$fatpacked{"Log/Contextual.pm"} = <<'LOG_CONTEXTUAL';
  package Log::Contextual;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.004001';
  
  my @levels = qw(debug trace warn info error fatal);
  
  use Exporter::Declare;
  use Exporter::Declare::Export::Generator;
  use Data::Dumper::Concise;
  use Scalar::Util 'blessed';
  
  my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
  
  my @log = ((map "log_$_", @levels), (map "logS_$_", @levels));
  
  eval {
     require Log::Log4perl;
     die if $Log::Log4perl::VERSION < 1.29;
     Log::Log4perl->wrapper_register(__PACKAGE__)
  };
  
  # ____ is because tags must have at least one export and we don't want to
  # export anything but the levels selected
  sub ____ {}
  
  exports ('____',
     @dlog, @log,
     qw( set_logger with_logger )
  );
  
  export_tag dlog => ('____');
  export_tag log  => ('____');
  import_arguments qw(logger package_logger default_logger);
  
  sub before_import {
     my ($class, $importer, $spec) = @_;
  
     die 'Log::Contextual does not have a default import list'
        if $spec->config->{default};
  
     my @levels = @{$class->arg_levels($spec->config->{levels})};
     for my $level (@levels) {
        if ($spec->config->{log}) {
           $spec->add_export("&log_$level", sub (&@) {
              _do_log( $level => _get_logger( caller ), shift @_, @_)
           });
           $spec->add_export("&logS_$level", sub (&@) {
              _do_logS( $level => _get_logger( caller ), $_[0], $_[1])
           });
        }
        if ($spec->config->{dlog}) {
           $spec->add_export("&Dlog_$level", sub (&@) {
             my ($code, @args) = @_;
             return _do_log( $level => _get_logger( caller ), sub {
                local $_ = (@args?Data::Dumper::Concise::Dumper @args:'()');
                $code->(@_)
             }, @args );
           });
           $spec->add_export("&DlogS_$level", sub (&$) {
             my ($code, $ref) = @_;
             _do_logS( $level => _get_logger( caller ), sub {
                local $_ = Data::Dumper::Concise::Dumper $ref;
                $code->($ref)
             }, $ref )
           });
        }
     }
  }
  
  sub arg_logger { $_[1] }
  sub arg_levels { $_[1] || [qw(debug trace warn info error fatal)] }
  sub arg_package_logger { $_[1] }
  sub arg_default_logger { $_[1] }
  
  sub after_import {
     my ($class, $importer, $specs) = @_;
  
     if (my $l = $class->arg_logger($specs->config->{logger})) {
        set_logger($l)
     }
  
     if (my $l = $class->arg_package_logger($specs->config->{package_logger})) {
        _set_package_logger_for($importer, $l)
     }
  
     if (my $l = $class->arg_default_logger($specs->config->{default_logger})) {
        _set_default_logger_for($importer, $l)
     }
  }
  
  our $Get_Logger;
  our %Default_Logger;
  our %Package_Logger;
  
  sub _set_default_logger_for {
     my $logger = $_[1];
     if(ref $logger ne 'CODE') {
        die 'logger was not a CodeRef or a logger object.  Please try again.'
           unless blessed($logger);
        $logger = do { my $l = $logger; sub { $l } }
     }
     $Default_Logger{$_[0]} = $logger
  }
  
  sub _set_package_logger_for {
     my $logger = $_[1];
     if(ref $logger ne 'CODE') {
        die 'logger was not a CodeRef or a logger object.  Please try again.'
           unless blessed($logger);
        $logger = do { my $l = $logger; sub { $l } }
     }
     $Package_Logger{$_[0]} = $logger
  }
  
  sub _get_logger($) {
     my $package = shift;
     (
        $Package_Logger{$package} ||
        $Get_Logger ||
        $Default_Logger{$package} ||
        die q( no logger set!  you can't try to log something without a logger! )
     )->($package);
  }
  
  sub set_logger {
     my $logger = $_[0];
     if(ref $logger ne 'CODE') {
        die 'logger was not a CodeRef or a logger object.  Please try again.'
           unless blessed($logger);
        $logger = do { my $l = $logger; sub { $l } }
     }
  
     warn 'set_logger (or -logger) called more than once!  This is a bad idea!'
        if $Get_Logger;
     $Get_Logger = $logger;
  }
  
  sub with_logger {
     my $logger = $_[0];
     if(ref $logger ne 'CODE') {
        die 'logger was not a CodeRef or a logger object.  Please try again.'
           unless blessed($logger);
        $logger = do { my $l = $logger; sub { $l } }
     }
     local $Get_Logger = $logger;
     $_[1]->();
  }
  
  sub _do_log {
     my $level  = shift;
     my $logger = shift;
     my $code   = shift;
     my @values = @_;
  
     $logger->$level($code->(@_))
        if $logger->${\"is_$level"};
     @values
  }
  
  sub _do_logS {
     my $level  = shift;
     my $logger = shift;
     my $code   = shift;
     my $value  = shift;
  
     $logger->$level($code->($value))
        if $logger->${\"is_$level"};
     $value
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Log::Contextual - Simple logging interface with a contextual log
  
  =head1 SYNOPSIS
  
   use Log::Contextual qw( :log :dlog set_logger with_logger );
   use Log::Contextual::SimpleLogger;
   use Log::Log4perl ':easy';
   Log::Log4perl->easy_init($DEBUG);
  
  
   my $logger  = Log::Log4perl->get_logger;
  
   set_logger $logger;
  
   log_debug { 'program started' };
  
   sub foo {
     with_logger(Log::Contextual::SimpleLogger->new({
         levels => [qw( trace debug )]
       }) => sub {
       log_trace { 'foo entered' };
       my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @_;
       # ...
       log_trace { 'foo left' };
     });
   }
  
   foo();
  
  Beginning with version 1.008 L<Log::Dispatchouli> also works out of the box
  with C<Log::Contextual>:
  
   use Log::Contextual qw( :log :dlog set_logger );
   use Log::Dispatchouli;
   my $ld = Log::Dispatchouli->new({
      ident     => 'slrtbrfst',
      to_stderr => 1,
      debug     => 1,
   });
  
   set_logger $ld;
  
   log_debug { 'program started' };
  
  =head1 DESCRIPTION
  
  This module is a simple interface to extensible logging.  It is bundled with a
  really basic logger, L<Log::Contextual::SimpleLogger>, but in general you
  should use a real logger instead of that.  For something more serious but not
  overly complicated, try L<Log::Dispatchouli> (see L</SYNOPSIS> for example.)
  
  The reason for this module is to abstract your logging interface so that
  logging is as painless as possible, while still allowing you to switch from one
  logger to another.
  
  =head1 A WORK IN PROGRESS
  
  This module is certainly not complete, but we will not break the interface
  lightly, so I would say it's safe to use in production code.  The main result
  from that at this point is that doing:
  
   use Log::Contextual;
  
  will die as we do not yet know what the defaults should be.  If it turns out
  that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll
  probably make C<:log> the default.  But only time and usage will tell.
  
  =head1 IMPORT OPTIONS
  
  See L</SETTING DEFAULT IMPORT OPTIONS> for information on setting these project
  wide.
  
  =head2 -logger
  
  When you import this module you may use C<-logger> as a shortcut for
  L<set_logger>, for example:
  
   use Log::Contextual::SimpleLogger;
   use Log::Contextual qw( :dlog ),
     -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] });
  
  sometimes you might want to have the logger handy for other stuff, in which
  case you might try something like the following:
  
   my $var_log;
   BEGIN { $var_log = VarLogger->new }
   use Log::Contextual qw( :dlog ), -logger => $var_log;
  
  =head2 -levels
  
  The C<-levels> import option allows you to define exactly which levels your
  logger supports.  So the default,
  C<< [qw(debug trace warn info error fatal)] >>, works great for
  L<Log::Log4perl>, but it doesn't support the levels for L<Log::Dispatch>.  But
  supporting those levels is as easy as doing
  
   use Log::Contextual
     -levels => [qw( debug info notice warning error critical alert emergency )];
  
  =head2 -package_logger
  
  The C<-package_logger> import option is similar to the C<-logger> import option
  except C<-package_logger> sets the the logger for the current package.
  
  Unlike L</-default_logger>, C<-package_logger> cannot be overridden with
  L</set_logger>.
  
   package My::Package;
   use Log::Contextual::SimpleLogger;
   use Log::Contextual qw( :log ),
     -package_logger => Log::Contextual::WarnLogger->new({
        env_prefix => 'MY_PACKAGE'
     });
  
  If you are interested in using this package for a module you are putting on
  CPAN we recommend L<Log::Contextual::WarnLogger> for your package logger.
  
  =head2 -default_logger
  
  The C<-default_logger> import option is similar to the C<-logger> import option
  except C<-default_logger> sets the the B<default> logger for the current package.
  
  Basically it sets the logger to be used if C<set_logger> is never called; so
  
   package My::Package;
   use Log::Contextual::SimpleLogger;
   use Log::Contextual qw( :log ),
     -default_logger => Log::Contextual::WarnLogger->new({
        env_prefix => 'MY_PACKAGE'
     });
  
  =head1 SETTING DEFAULT IMPORT OPTIONS
  
  Eventually you will get tired of writing the following in every single one of
  your packages:
  
   use Log::Log4perl;
   use Log::Log4perl ':easy';
   BEGIN { Log::Log4perl->easy_init($DEBUG) }
  
   use Log::Contextual -logger => Log::Log4perl->get_logger;
  
  You can set any of the import options for your whole project if you define your
  own C<Log::Contextual> subclass as follows:
  
   package MyApp::Log::Contextual;
  
   use base 'Log::Contextual';
  
   use Log::Log4perl ':easy';
   Log::Log4perl->easy_init($DEBUG)
  
   sub arg_logger { $_[1] || Log::Log4perl->get_logger }
   sub arg_levels { [qw(debug trace warn info error fatal custom_level)] }
  
   # and *maybe* even these:
   sub arg_package_logger { $_[1] }
   sub arg_default_logger { $_[1] }
  
  Note the C<< $_[1] || >> in C<arg_logger>.  All of these methods are passed the
  values passed in from the arguments to the subclass, so you can either throw
  them away, honor them, die on usage, or whatever.  To be clear, if you define
  your subclass, and someone uses it as follows:
  
   use MyApp::Log::Contextual -logger => $foo, -levels => [qw(bar baz biff)];
  
  Your C<arg_logger> method will get C<$foo> and your C<arg_levels>
  will get C<[qw(bar baz biff)]>;
  
  =head1 FUNCTIONS
  
  =head2 set_logger
  
   my $logger = WarnLogger->new;
   set_logger $logger;
  
  Arguments: C<Ref|CodeRef $returning_logger>
  
  C<set_logger> will just set the current logger to whatever you pass it.  It
  expects a C<CodeRef>, but if you pass it something else it will wrap it in a
  C<CodeRef> for you.  C<set_logger> is really meant only to be called from a
  top-level script.  To avoid foot-shooting the function will warn if you call it
  more than once.
  
  =head2 with_logger
  
   my $logger = WarnLogger->new;
   with_logger $logger => sub {
      if (1 == 0) {
         log_fatal { 'Non Logical Universe Detected' };
      } else {
         log_info  { 'All is good' };
      }
   };
  
  Arguments: C<Ref|CodeRef $returning_logger, CodeRef $to_execute>
  
  C<with_logger> sets the logger for the scope of the C<CodeRef> C<$to_execute>.
  As with L</set_logger>, C<with_logger> will wrap C<$returning_logger> with a
  C<CodeRef> if needed.
  
  =head2 log_$level
  
  Import Tag: C<:log>
  
  Arguments: C<CodeRef $returning_message, @args>
  
  All of the following six functions work the same except that a different method
  is called on the underlying C<$logger> object.  The basic pattern is:
  
   sub log_$level (&@) {
     if ($logger->is_$level) {
       $logger->$level(shift->(@_));
     }
     @_
   }
  
  Note that the function returns it's arguments.  This can be used in a number of
  ways, but often it's convenient just for partial inspection of passthrough data
  
   my @friends = log_trace {
     'friends list being generated, data from first friend: ' .
       Dumper($_[0]->TO_JSON)
   } generate_friend_list();
  
  If you want complete inspection of passthrough data, take a look at the
  L</Dlog_$level> functions.
  
  =head3 log_trace
  
   log_trace { 'entered method foo with args ' join q{,}, @args };
  
  =head3 log_debug
  
   log_debug { 'entered method foo' };
  
  =head3 log_info
  
   log_info { 'started process foo' };
  
  =head3 log_warn
  
   log_warn { 'possible misconfiguration at line 10' };
  
  =head3 log_error
  
   log_error { 'non-numeric user input!' };
  
  =head3 log_fatal
  
   log_fatal { '1 is never equal to 0!' };
  
  =head2 logS_$level
  
  Import Tag: C<:log>
  
  Arguments: C<CodeRef $returning_message, Item $arg>
  
  This is really just a special case of the L</log_$level> functions.  It forces
  scalar context when that is what you need.  Other than that it works exactly
  same:
  
   my $friend = logS_trace {
     'I only have one friend: ' .  Dumper($_[0]->TO_JSON)
   } friend();
  
  See also: L</DlogS_$level>.
  
  =head2 Dlog_$level
  
  Import Tag: C<:dlog>
  
  Arguments: C<CodeRef $returning_message, @args>
  
  All of the following six functions work the same as their L</log_$level>
  brethren, except they return what is passed into them and put the stringified
  (with L<Data::Dumper::Concise>) version of their args into C<$_>.  This means
  you can do cool things like the following:
  
   my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all;
  
  and the output might look something like:
  
   names: "fREW"
   "fRIOUX"
   "fROOH"
   "fRUE"
   "fiSMBoC"
  
  =head3 Dlog_trace
  
   my ($foo, $bar) = Dlog_trace { "entered method foo with args: $_" } @_;
  
  =head3 Dlog_debug
  
   Dlog_debug { "random data structure: $_" } { foo => $bar };
  
  =head3 Dlog_info
  
   return Dlog_info { "html from method returned: $_" } "<html>...</html>";
  
  =head3 Dlog_warn
  
   Dlog_warn { "probably invalid value: $_" } $foo;
  
  =head3 Dlog_error
  
   Dlog_error { "non-numeric user input! ($_)" } $port;
  
  =head3 Dlog_fatal
  
   Dlog_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0;
  
  =head2 DlogS_$level
  
  Import Tag: C<:dlog>
  
  Arguments: C<CodeRef $returning_message, Item $arg>
  
  Like L</logS_$level>, these functions are a special case of L</Dlog_$level>.
  They only take a single scalar after the C<$returning_message> instead of
  slurping up (and also setting C<wantarray>) all the C<@args>
  
   my $pals_rs = DlogS_debug { "pals resultset: $_" }
     $schema->resultset('Pals')->search({ perlers => 1 });
  
  =head1 LOGGER INTERFACE
  
  Because this module is ultimately pretty looking glue (glittery?) with the
  awesome benefit of the Contextual part, users will often want to make their
  favorite logger work with it.  The following are the methods that should be
  implemented in the logger:
  
   is_trace
   is_debug
   is_info
   is_warn
   is_error
   is_fatal
   trace
   debug
   info
   warn
   error
   fatal
  
  The first six merely need to return true if that level is enabled.  The latter
  six take the results of whatever the user returned from their coderef and log
  them.  For a basic example see L<Log::Contextual::SimpleLogger>.
  
  =head1 AUTHOR
  
  frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
  
  =head1 DESIGNER
  
  mst - Matt S. Trout <mst@shadowcat.co.uk>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
  above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms as
  Perl 5 itself.
  
  =cut
  
LOG_CONTEXTUAL

$fatpacked{"Log/Contextual/SimpleLogger.pm"} = <<'LOG_CONTEXTUAL_SIMPLELOGGER';
  package Log::Contextual::SimpleLogger;
  
  use strict;
  use warnings;
  
  {
    for my $name (qw( trace debug info warn error fatal )) {
  
      no strict 'refs';
  
      *{$name} = sub {
        my $self = shift;
  
        $self->_log( $name, @_ )
          if ($self->{$name});
      };
  
      *{"is_$name"} = sub {
        my $self = shift;
        return $self->{$name};
      };
    }
  }
  
  sub new {
    my ($class, $args) = @_;
    my $self = bless {}, $class;
  
    $self->{$_} = 1 for @{$args->{levels}};
    $self->{coderef} = $args->{coderef} || sub { print STDERR @_};
  
    if (my $upto = $args->{levels_upto}) {
  
      my @levels = (qw( trace debug info warn error fatal ));
      my $i = 0;
      for (@levels) {
        last if $upto eq $_;
        $i++
      }
      for ($i..$#levels) {
        $self->{$levels[$_]} = 1
      }
  
    }
    return $self;
  }
  
  sub _log {
    my $self    = shift;
    my $level   = shift;
    my $message = join( "\n", @_ );
    $message .= "\n" unless $message =~ /\n$/;
    $self->{coderef}->(sprintf( "[%s] %s", $level, $message ));
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Log::Contextual::SimpleLogger - Super simple logger made for playing with Log::Contextual
  
  =head1 SYNOPSIS
  
   use Log::Contextual::SimpleLogger;
   use Log::Contextual qw( :log ),
     -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )]});
  
   log_info { 'program started' }; # no-op because info is not in levels
   sub foo {
     log_debug { 'entered foo' };
     ...
   }
  
  =head1 DESCRIPTION
  
  This module is a simple logger made mostly for demonstration and initial
  experimentation with L<Log::Contextual>.  We recommend you use a real logger
  instead.  For something more serious but not overly complicated, take a look at
  L<Log::Dispatchouli>.
  
  =head1 METHODS
  
  =head2 new
  
  Arguments: C<< Dict[
    levels      => Optional[ArrayRef[Str]],
    levels_upto => Level,
    coderef     => Optional[CodeRef],
  ] $conf >>
  
   my $l = Log::Contextual::SimpleLogger->new({
     levels  => [qw( info warn )],
     coderef => sub { print @_ }, # the default prints to STDERR
   });
  
  or
  
   my $l = Log::Contextual::SimpleLogger->new({
     levels_upto => 'debug',
     coderef     => sub { print @_ }, # the default prints to STDERR
   });
  
  Creates a new SimpleLogger object with the passed levels enabled and optionally
  a C<CodeRef> may be passed to modify how the logs are output/stored.
  
  C<levels_upto> enables all the levels upto and including the level passed.
  
  Levels may contain:
  
   trace
   debug
   info
   warn
   error
   fatal
  
  =head2 $level
  
  Arguments: C<@anything>
  
  All of the following six methods work the same.  The basic pattern is:
  
   sub $level {
     my $self = shift;
  
     print STDERR "[$level] " . join qq{\n}, @_;
        if $self->is_$level;
   }
  
  =head3 trace
  
   $l->trace( 'entered method foo with args ' join q{,}, @args );
  
  =head3 debug
  
   $l->debug( 'entered method foo' );
  
  =head3 info
  
   $l->info( 'started process foo' );
  
  =head3 warn
  
   $l->warn( 'possible misconfiguration at line 10' );
  
  =head3 error
  
   $l->error( 'non-numeric user input!' );
  
  =head3 fatal
  
   $l->fatal( '1 is never equal to 0!' );
  
  =head2 is_$level
  
  All of the following six functions just return true if their respective
  level is enabled.
  
  =head3 is_trace
  
   say 'tracing' if $l->is_trace;
  
  =head3 is_debug
  
   say 'debuging' if $l->is_debug;
  
  =head3 is_info
  
   say q{info'ing} if $l->is_info;
  
  =head3 is_warn
  
   say 'warning' if $l->is_warn;
  
  =head3 is_error
  
   say 'erroring' if $l->is_error;
  
  =head3 is_fatal
  
   say q{fatal'ing} if $l->is_fatal;
  
  =head1 AUTHOR
  
  See L<Log::Contextual/"AUTHOR">
  
  =head1 COPYRIGHT
  
  See L<Log::Contextual/"COPYRIGHT">
  
  =head1 LICENSE
  
  See L<Log::Contextual/"LICENSE">
  
  =cut
  
LOG_CONTEXTUAL_SIMPLELOGGER

$fatpacked{"Log/Contextual/TeeLogger.pm"} = <<'LOG_CONTEXTUAL_TEELOGGER';
  package Log::Contextual::TeeLogger;
  
  use strict;
  use warnings;
  
  {
    for my $name (qw( trace debug info warn error fatal )) {
  
      no strict 'refs';
  
      *{$name} = sub {
        my $self = shift;
  
        foreach my $logger (@{$self->{loggers}}) {
          $logger->$name(@_);
        }
      };
  
      my $is_name = "is_${name}";
  
      *{$is_name} = sub {
        my $self = shift;
        foreach my $logger (@{$self->{loggers}}) {
          return 1 if $logger->$is_name(@_);
        }
        return 0;
      };
    }
  }
  
  sub new {
    my ($class, $args) = @_;
    my $self = bless {}, $class;
  
    ref($self->{loggers} = $args->{loggers}) eq 'ARRAY'
      or die "No loggers passed to tee logger";
  
    return $self;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Log::Contextual::TeeLogger - Output to more than one logger
  
  =head1 SYNOPSIS
  
   use Log::Contextual::SimpleLogger;
   use Log::Contextual::TeeLogger;
   use Log::Contextual qw( :log ),
     -logger => Log::Contextual::TeeLogger->new({ loggers => [
       Log::Contextual::SimpleLogger->new({ levels => [ 'debug' ] }),
       Log::Contextual::SimpleLogger->new({
         levels => [ 'info' ],
         coderef => sub { print @_ },
       }),
     ]});
  
   ## docs below here not yet edited
  
   log_info { 'program started' }; # no-op because info is not in levels
   sub foo {
     log_debug { 'entered foo' };
     ...
   }
  
  =head1 DESCRIPTION
  
  This module is a simple logger made mostly for demonstration and initial
  experimentation with L<Log::Contextual>.  We recommend you use a real logger
  instead.  For something more serious but not overly complicated, take a look at
  L<Log::Dispatchouli>.
  
  =head1 METHODS
  
  =head2 new
  
  Arguments: C<< Dict[ levels => ArrayRef[Str], coderef => Optional[CodeRef] ] $conf >>
  
   my $l = Log::Contextual::SimpleLogger->new({
     levels => [qw( info warn )],
     coderef => sub { print @_ }, # the default prints to STDERR
   });
  
  Creates a new SimpleLogger object with the passed levels enabled and optionally
  a C<CodeRef> may be passed to modify how the logs are output/stored.
  
  Levels may contain:
  
   trace
   debug
   info
   warn
   error
   fatal
  
  =head2 $level
  
  Arguments: C<@anything>
  
  All of the following six methods work the same.  The basic pattern is:
  
   sub $level {
     my $self = shift;
  
     print STDERR "[$level] " . join qq{\n}, @_;
        if $self->is_$level;
   }
  
  =head3 trace
  
   $l->trace( 'entered method foo with args ' join q{,}, @args );
  
  =head3 debug
  
   $l->debug( 'entered method foo' );
  
  =head3 info
  
   $l->info( 'started process foo' );
  
  =head3 warn
  
   $l->warn( 'possible misconfiguration at line 10' );
  
  =head3 error
  
   $l->error( 'non-numeric user input!' );
  
  =head3 fatal
  
   $l->fatal( '1 is never equal to 0!' );
  
  =head2 is_$level
  
  All of the following six functions just return true if their respective
  level is enabled.
  
  =head3 is_trace
  
   say 'tracing' if $l->is_trace;
  
  =head3 is_debug
  
   say 'debuging' if $l->is_debug;
  
  =head3 is_info
  
   say q{info'ing} if $l->is_info;
  
  =head3 is_warn
  
   say 'warning' if $l->is_warn;
  
  =head3 is_error
  
   say 'erroring' if $l->is_error;
  
  =head3 is_fatal
  
   say q{fatal'ing} if $l->is_fatal;
  
  =head1 AUTHOR
  
  See L<Log::Contextual/"AUTHOR">
  
  =head1 COPYRIGHT
  
  See L<Log::Contextual/"COPYRIGHT">
  
  =head1 LICENSE
  
  See L<Log::Contextual/"LICENSE">
  
  =cut
  
LOG_CONTEXTUAL_TEELOGGER

$fatpacked{"Log/Contextual/WarnLogger.pm"} = <<'LOG_CONTEXTUAL_WARNLOGGER';
  package Log::Contextual::WarnLogger;
  
  use strict;
  use warnings;
  
  {
    my @levels = (qw( trace debug info warn error fatal ));
    my %level_num; @level_num{ @levels } = (0 .. $#levels);
    for my $name (@levels) {
  
      no strict 'refs';
  
      my $is_name = "is_$name";
      *{$name} = sub {
        my $self = shift;
  
        $self->_log( $name, @_ )
          if $self->$is_name;
      };
  
      *{$is_name} = sub {
        my $self = shift;
        return 1 if $ENV{$self->{env_prefix} . '_' . uc $name};
        my $upto = $ENV{$self->{env_prefix} . '_UPTO'};
        return unless $upto;
        $upto = lc $upto;
  
        return $level_num{$name} >= $level_num{$upto};
      };
    }
  }
  
  sub new {
    my ($class, $args) = @_;
    my $self = bless {}, $class;
  
    $self->{env_prefix} = $args->{env_prefix} or
       die 'no env_prefix passed to Log::Contextual::WarnLogger->new';
    return $self;
  }
  
  sub _log {
    my $self    = shift;
    my $level   = shift;
    my $message = join( "\n", @_ );
    $message .= "\n" unless $message =~ /\n$/;
    warn "[$level] $message";
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Log::Contextual::WarnLogger - Simple logger for libraries using Log::Contextual
  
  =head1 SYNOPSIS
  
   package My::Package;
   use Log::Contextual::WarnLogger;
   use Log::Contextual qw( :log ),
     -default_logger => Log::Contextual::WarnLogger->new({
        env_prefix => 'MY_PACKAGE'
     });
  
   # warns '[info] program started' if $ENV{MY_PACKAGE_TRACE} is set
   log_info { 'program started' }; # no-op because info is not in levels
   sub foo {
     # warns '[debug] entered foo' if $ENV{MY_PACKAGE_DEBUG} is set
     log_debug { 'entered foo' };
     ...
   }
  
  =head1 DESCRIPTION
  
  This module is a simple logger made for libraries using L<Log::Contextual>.  We
  recommend the use of this logger as your default logger as it is simple and
  useful for most users, yet users can use L<Log::Contextual/set_logger> to override
  your choice of logger in their own code thanks to the way L<Log::Contextual>
  works.
  
  =head1 METHODS
  
  =head2 new
  
  Arguments: C<< Dict[ env_prefix => Str ] $conf >>
  
   my $l = Log::Contextual::WarnLogger->new({
     env_prefix
   });
  
  Creates a new logger object where C<env_prefix> defines what the prefix is for
  the environment variables that will be checked for the six log levels.  For
  example, if C<env_prefix> is set to C<FREWS_PACKAGE> the following environment
  variables will be used:
  
   FREWS_PACKAGE_UPTO
  
   FREWS_PACKAGE_TRACE
   FREWS_PACKAGE_DEBUG
   FREWS_PACKAGE_INFO
   FREWS_PACKAGE_WARN
   FREWS_PACKAGE_ERROR
   FREWS_PACKAGE_FATAL
  
  Note that C<UPTO> is a convenience variable.  If you set
  C<< FOO_UPTO=TRACE >> it will enable all log levels.  Similarly, if you
  set it to C<FATAL> only fatal will be enabled.
  
  =head2 $level
  
  Arguments: C<@anything>
  
  All of the following six methods work the same.  The basic pattern is:
  
   sub $level {
     my $self = shift;
  
     warn "[$level] " . join qq{\n}, @_;
        if $self->is_$level;
   }
  
  =head3 trace
  
   $l->trace( 'entered method foo with args ' join q{,}, @args );
  
  =head3 debug
  
   $l->debug( 'entered method foo' );
  
  =head3 info
  
   $l->info( 'started process foo' );
  
  =head3 warn
  
   $l->warn( 'possible misconfiguration at line 10' );
  
  =head3 error
  
   $l->error( 'non-numeric user input!' );
  
  =head3 fatal
  
   $l->fatal( '1 is never equal to 0!' );
  
  =head2 is_$level
  
  All of the following six functions just return true if their respective
  environment variable is enabled.
  
  =head3 is_trace
  
   say 'tracing' if $l->is_trace;
  
  =head3 is_debug
  
   say 'debuging' if $l->is_debug;
  
  =head3 is_info
  
   say q{info'ing} if $l->is_info;
  
  =head3 is_warn
  
   say 'warning' if $l->is_warn;
  
  =head3 is_error
  
   say 'erroring' if $l->is_error;
  
  =head3 is_fatal
  
   say q{fatal'ing} if $l->is_fatal;
  
  =head1 AUTHOR
  
  See L<Log::Contextual/"AUTHOR">
  
  =head1 COPYRIGHT
  
  See L<Log::Contextual/"COPYRIGHT">
  
  =head1 LICENSE
  
  See L<Log::Contextual/"LICENSE">
  
  =cut
  
LOG_CONTEXTUAL_WARNLOGGER

$fatpacked{"MRO/Compat.pm"} = <<'MRO_COMPAT';
  package MRO::Compat;
  use strict;
  use warnings;
  require 5.006_000;
  
  # Keep this < 1.00, so people can tell the fake
  #  mro.pm from the real one
  our $VERSION = '0.11';
  
  BEGIN {
      # Alias our private functions over to
      # the mro:: namespace and load
      # Class::C3 if Perl < 5.9.5
      if($] < 5.009_005) {
          $mro::VERSION # to fool Module::Install when generating META.yml
              = $VERSION;
          $INC{'mro.pm'} = __FILE__;
          *mro::import            = \&__import;
          *mro::get_linear_isa    = \&__get_linear_isa;
          *mro::set_mro           = \&__set_mro;
          *mro::get_mro           = \&__get_mro;
          *mro::get_isarev        = \&__get_isarev;
          *mro::is_universal      = \&__is_universal;
          *mro::method_changed_in = \&__method_changed_in;
          *mro::invalidate_all_method_caches
                                  = \&__invalidate_all_method_caches;
          require Class::C3;
          if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
              *mro::get_pkg_gen   = \&__get_pkg_gen_c3xs;
          }
          else {
              *mro::get_pkg_gen   = \&__get_pkg_gen_pp;
          }
      }
  
      # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
      else {
          require mro;
          no warnings 'redefine';
          *Class::C3::initialize = sub { 1 };
          *Class::C3::reinitialize = sub { 1 };
          *Class::C3::uninitialize = sub { 1 };
      }
  }
  
  =head1 NAME
  
  MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
  
  =head1 SYNOPSIS
  
     package FooClass; use base qw/X Y Z/;
     package X;        use base qw/ZZZ/;
     package Y;        use base qw/ZZZ/;
     package Z;        use base qw/ZZZ/;
  
     package main;
     use MRO::Compat;
     my $linear = mro::get_linear_isa('FooClass');
     print join(q{, }, @$linear);
  
     # Prints: "FooClass, X, ZZZ, Y, Z"
  
  =head1 DESCRIPTION
  
  The "mro" namespace provides several utilities for dealing
  with method resolution order and method caching in general
  in Perl 5.9.5 and higher.
  
  This module provides those interfaces for
  earlier versions of Perl (back to 5.6.0 anyways).
  
  It is a harmless no-op to use this module on 5.9.5+.  That
  is to say, code which properly uses L<MRO::Compat> will work
  unmodified on both older Perls and 5.9.5+.
  
  If you're writing a piece of software that would like to use
  the parts of 5.9.5+'s mro:: interfaces that are supported
  here, and you want compatibility with older Perls, this
  is the module for you.
  
  Some parts of this code will work better and/or faster with
  L<Class::C3::XS> installed (which is an optional prereq
  of L<Class::C3>, which is in turn a prereq of this
  package), but it's not a requirement.
  
  This module never exports any functions.  All calls must
  be fully qualified with the C<mro::> prefix.
  
  The interface documentation here serves only as a quick
  reference of what the function basically does, and what
  differences between L<MRO::Compat> and 5.9.5+ one should
  look out for.  The main docs in 5.9.5's L<mro> are the real
  interface docs, and contain a lot of other useful information.
  
  =head1 Functions
  
  =head2 mro::get_linear_isa($classname[, $type])
  
  Returns an arrayref which is the linearized "ISA" of the given class.
  Uses whichever MRO is currently in effect for that class by default,
  or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
  
  The linearized ISA of a class is a single ordered list of all of the
  classes that would be visited in the process of resolving a method
  on the given class, starting with itself.  It does not include any
  duplicate entries.
  
  Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
  part of the MRO of a class, even though all classes implicitly inherit
  methods from C<UNIVERSAL> and its parents.
  
  =cut
  
  sub __get_linear_isa_dfs {
      no strict 'refs';
  
      my $classname = shift;
  
      my @lin = ($classname);
      my %stored;
      foreach my $parent (@{"$classname\::ISA"}) {
          my $plin = __get_linear_isa_dfs($parent);
          foreach (@$plin) {
              next if exists $stored{$_};
              push(@lin, $_);
              $stored{$_} = 1;
          }
      }
      return \@lin;
  }
  
  sub __get_linear_isa {
      my ($classname, $type) = @_;
      die "mro::get_mro requires a classname" if !defined $classname;
  
      $type ||= __get_mro($classname);
      if($type eq 'dfs') {
          return __get_linear_isa_dfs($classname);
      }
      elsif($type eq 'c3') {
          return [Class::C3::calculateMRO($classname)];
      }
      die "type argument must be 'dfs' or 'c3'";
  }
  
  =head2 mro::import
  
  This allows the C<use mro 'dfs'> and
  C<use mro 'c3'> syntaxes, providing you
  L<use MRO::Compat> first.  Please see the
  L</USING C3> section for additional details.
  
  =cut
  
  sub __import {
      if($_[1]) {
          goto &Class::C3::import if $_[1] eq 'c3';
          __set_mro(scalar(caller), $_[1]);
      }
  }
  
  =head2 mro::set_mro($classname, $type)
  
  Sets the mro of C<$classname> to one of the types
  C<dfs> or C<c3>.  Please see the L</USING C3>
  section for additional details.
  
  =cut
  
  sub __set_mro {
      my ($classname, $type) = @_;
  
      if(!defined $classname || !$type) {
          die q{Usage: mro::set_mro($classname, $type)};
      }
  
      if($type eq 'c3') {
          eval "package $classname; use Class::C3";
          die $@ if $@;
      }
      elsif($type eq 'dfs') {
          # In the dfs case, check whether we need to undo C3
          if(defined $Class::C3::MRO{$classname}) {
              Class::C3::_remove_method_dispatch_table($classname);
          }
          delete $Class::C3::MRO{$classname};
      }
      else {
          die qq{Invalid mro type "$type"};
      }
  
      return;
  }
  
  =head2 mro::get_mro($classname)
  
  Returns the MRO of the given class (either C<c3> or C<dfs>).
  
  It considers any Class::C3-using class to have C3 MRO
  even before L<Class::C3::initialize()> is called.
  
  =cut
  
  sub __get_mro {
      my $classname = shift;
      die "mro::get_mro requires a classname" if !defined $classname;
      return 'c3' if exists $Class::C3::MRO{$classname};
      return 'dfs';
  }
  
  =head2 mro::get_isarev($classname)
  
  Returns an arrayref of classes who are subclasses of the
  given classname.  In other words, classes in whose @ISA
  hierarchy we appear, no matter how indirectly.
  
  This is much slower on pre-5.9.5 Perls with MRO::Compat
  than it is on 5.9.5+, as it has to search the entire
  package namespace.
  
  =cut
  
  sub __get_all_pkgs_with_isas {
      no strict 'refs';
      no warnings 'recursion';
  
      my @retval;
  
      my $search = shift;
      my $pfx;
      my $isa;
      if(defined $search) {
          $isa = \@{"$search\::ISA"};
          $pfx = "$search\::";
      }
      else {
          $search = 'main';
          $isa = \@main::ISA;
          $pfx = '';
      }
  
      push(@retval, $search) if scalar(@$isa);
  
      foreach my $cand (keys %{"$search\::"}) {
          if($cand =~ s/::$//) {
              next if $cand eq $search; # skip self-reference (main?)
              push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
          }
      }
  
      return \@retval;
  }
  
  sub __get_isarev_recurse {
      no strict 'refs';
  
      my ($class, $all_isas, $level) = @_;
  
      die "Recursive inheritance detected" if $level > 100;
  
      my %retval;
  
      foreach my $cand (@$all_isas) {
          my $found_me;
          foreach (@{"$cand\::ISA"}) {
              if($_ eq $class) {
                  $found_me = 1;
                  last;
              }
          }
          if($found_me) {
              $retval{$cand} = 1;
              map { $retval{$_} = 1 }
                  @{__get_isarev_recurse($cand, $all_isas, $level+1)};
          }
      }
      return [keys %retval];
  }
  
  sub __get_isarev {
      my $classname = shift;
      die "mro::get_isarev requires a classname" if !defined $classname;
  
      __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
  }
  
  =head2 mro::is_universal($classname)
  
  Returns a boolean status indicating whether or not
  the given classname is either C<UNIVERSAL> itself,
  or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
  
  Any class for which this function returns true is
  "universal" in the sense that all classes potentially
  inherit methods from it.
  
  =cut
  
  sub __is_universal {
      my $classname = shift;
      die "mro::is_universal requires a classname" if !defined $classname;
  
      my $lin = __get_linear_isa('UNIVERSAL');
      foreach (@$lin) {
          return 1 if $classname eq $_;
      }
  
      return 0;
  }
  
  =head2 mro::invalidate_all_method_caches
  
  Increments C<PL_sub_generation>, which invalidates method
  caching in all packages.
  
  Please note that this is rarely necessary, unless you are
  dealing with a situation which is known to confuse Perl's
  method caching.
  
  =cut
  
  sub __invalidate_all_method_caches {
      # Super secret mystery code :)
      @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
      return;
  }
  
  =head2 mro::method_changed_in($classname)
  
  Invalidates the method cache of any classes dependent on the
  given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
  an alias for C<mro::invalidate_all_method_caches> above, as
  pre-5.9.5 Perls have no other way to do this.  It will still
  enforce the requirement that you pass it a classname, for
  compatibility.
  
  Please note that this is rarely necessary, unless you are
  dealing with a situation which is known to confuse Perl's
  method caching.
  
  =cut
  
  sub __method_changed_in {
      my $classname = shift;
      die "mro::method_changed_in requires a classname" if !defined $classname;
  
      __invalidate_all_method_caches();
  }
  
  =head2 mro::get_pkg_gen($classname)
  
  Returns an integer which is incremented every time a local
  method of or the C<@ISA> of the given package changes on
  Perl 5.9.5+.  On earlier Perls with this L<MRO::Compat> module,
  it will probably increment a lot more often than necessary.
  
  =cut
  
  {
      my $__pkg_gen = 2;
      sub __get_pkg_gen_pp {
          my $classname = shift;
          die "mro::get_pkg_gen requires a classname" if !defined $classname;
          return $__pkg_gen++;
      }
  }
  
  sub __get_pkg_gen_c3xs {
      my $classname = shift;
      die "mro::get_pkg_gen requires a classname" if !defined $classname;
  
      return Class::C3::XS::_plsubgen();
  }
  
  =head1 USING C3
  
  While this module makes the 5.9.5+ syntaxes
  C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
  on older Perls, it does so merely by passing off the work
  to L<Class::C3>.
  
  It does not remove the need for you to call
  C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
  C<Class::C3::uninitialize()> at the appropriate times
  as documented in the L<Class::C3> docs.  These three functions
  are always provided by L<MRO::Compat>, either via L<Class::C3>
  itself on older Perls, or directly as no-ops on 5.9.5+.
  
  =head1 SEE ALSO
  
  L<Class::C3>
  
  L<mro>
  
  =head1 AUTHOR
  
  Brandon L. Black, E<lt>blblack@gmail.comE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
  
  1;
MRO_COMPAT

$fatpacked{"Meta/Builder.pm"} = <<'META_BUILDER';
  package Meta::Builder;
  use strict;
  use warnings;
  
  use Carp qw/croak/;
  use Meta::Builder::Util;
  use Meta::Builder::Base;
  
  our $VERSION = "0.003";
  
  our @SUGAR = qw/metric action hash_metric lists_metric/;
  our @HOOKS = qw/before after/;
  our @METHODS = (( map { "add_$_"  } @SUGAR ),
                 ( map { "hook_$_" } @HOOKS ));
  our @EXPORT = ( @SUGAR, @HOOKS, qw/make_immutable accessor/ );
  our @REMOVABLE = ( @EXPORT, @METHODS );
  
  for my $item ( @SUGAR ) {
      my $wraps = "add_$item";
      inject( __PACKAGE__, $item, sub {
          caller->$wraps(@_)
      });
  }
  
  for my $item ( @HOOKS ) {
      my $wraps = "hook_$item";
      inject( __PACKAGE__, $item, sub {
          caller->$wraps(@_)
      });
  }
  
  sub import {
      my $class = shift;
      my $caller = caller;
  
      inject( $caller, $_, $class->can( $_ )) for @EXPORT;
      no strict 'refs';
      push @{"$caller\::ISA"} => 'Meta::Builder::Base';
  }
  
  sub make_immutable {
      my $class = shift || caller;
      for my $sub ( @REMOVABLE ) {
          inject( $class, $sub, sub {
              croak "$class has been made immutable, cannot call '$sub'"
          }, 1 );
      }
  }
  
  sub accessor {
      my $class = caller;
      $class->set_accessor( @_ );
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Meta::Builder - Tools for creating Meta objects to track custom metrics.
  
  =head1 DESCRIPTION
  
  Meta programming is becomming more and more popular. The popularity of Meta
  programming comes from the fact that many problems are made significantly
  easier. There are a few specialized Meta tools out there, for instance
  L<Class:MOP> which is used by L<Moose> to track class metadata.
  
  Meta::Builder is designed to be a generic tool for writing Meta objects. Unlike
  specialized tools, Meta::Builder makes no assumptions about what metrics you
  will care about. Meta::Builder also mkaes it simple for others to extend your
  meta-object based tools by providing hooks for other packages to add metrics to
  your meta object.
  
  If a specialized Meta object tool is available ot meet your needs please use
  it. However if you need a simple Meta object to track a couple metrics, use
  Meta::Builder.
  
  Meta::Builder is also low-sugar and low-dep. In most cases you will not want a
  class that needs a meta object to use your meta-object class directly. Rather
  you will usually want to create a sugar class that exports enhanced API
  functions that manipulate the meta object.
  
  =head1 SYNOPSIS
  
  My/Meta.pm:
  
      package My::Meta;
      use strict;
      use warnings;
  
      use Meta::Builder;
  
      # Name the accessor that will be defined in the class that uses the meta object
      # It is used to retrieve the classes meta object.
      accessor "mymeta";
  
      # Add a metric with two actions
      metric mymetric => sub { [] },
             pop => sub {
                 my $self = shift;
                 my ( $data ) = @_;
                 pop @$data;
             },
             push => sub {
                 my $self = shift;
                 my ( $data, $metric, $action, @args ) = @_;
                 push @$data => @args;
             };
  
      # Add an additional action to the metric
      action mymetric => ( get_ref => sub { shift });
  
      # Add some predefined metric types + actions
      hash_metric 'my_hashmetric';
      lists_metric 'my_listsmetric';
  
  My.pm:
  
      package My;
      use strict;
      use warnings;
  
      use My::Meta;
  
      My::Meta->new( __PACKAGE__ );
  
      # My::Meta defines mymeta() as the accessor we use to get our meta object.
      # this is the ONLY way to get the meta object for this class.
  
      mymeta()->mymetric_push( "some data" );
      mymeta()->my_hashmetric_add( key => 'value' );
      mymeta()->my_listsmetric_push( list => qw/valueA valueB/ );
  
      # It works fine as an object/class method as well.
      __PACKAGE__->mymeta->do_thing(...);
  
      ...;
  
  =head1 USING
  
  When you use Meta::Builder your class is automatically turned into a subclass
  of L<Meta::Builder::Base>. In addition several "sugar" functions are exported
  into your namespace. To avoid the "sugar" functions you can simply sublass
  L<Meta::Builder::Base> directly.
  
  =head1 EXPORTS
  
  =over 4
  
  =item metric( $name, \&generator, %actions )
  
  Wraper around C<caller->add_metric()>. See L<Meta::Builder::Base>.
  
  =item action( $metric, $name, $code )
  
  Wraper around C<caller->add_action()>. See L<Meta::Builder::Base>.
  
  =item hash_metric( $name, %additional_actions )
  
  Wraper around C<caller->add_hash_metric()>. See L<Meta::Builder::Base>.
  
  =item lists_metric( $name, %additional_actions )
  
  Wraper around C<caller->add_lists_metric()>. See L<Meta::Builder::Base>.
  
  =item before( $metric, $action, $code )
  
  Wraper around C<caller->hook_before()>. See L<Meta::Builder::Base>.
  
  =item after( $metric, $action, $code )
  
  Wraper around C<caller->hook_after()>. See L<Meta::Builder::Base>.
  
  =item accessor( $name )
  
  Wraper around C<caller->set_accessor()>. See L<Meta::Builder::Base>.
  
  =item make_immutable()
  
  Overrides all functions/methods that alter the meta objects meta-data. This in
  effect prevents anything from adding new metrics, actions, or hooks without
  directly editing the metadata.
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Meta-Builder is free software; Standard perl licence.
  
  Meta-Builder is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  FOR A PARTICULAR PURPOSE.  See the license for more details.
META_BUILDER

$fatpacked{"Meta/Builder/Base.pm"} = <<'META_BUILDER_BASE';
  package Meta::Builder::Base;
  use strict;
  use warnings;
  
  use Meta::Builder::Util;
  use Carp qw/croak carp/;
  
  sub new {
      my $class = shift;
      my ( $package, %metrics ) = @_;
      my $meta = $class->meta_meta;
      my $self = bless( [ $package ], $class );
  
      for my $metric ( keys %{ $meta->{metrics} }) {
          my $idx = $meta->{metrics}->{$metric};
          $self->[$idx] = $metrics{$metric}
                       || $meta->{generators}->[$idx]->();
      }
  
      inject(
          $package,
          ($meta->{accessor} || croak "$class does not have an accessor set."),
          sub { $self }
      );
  
      $self->init( %metrics ) if $self->can( 'init' );
  
      return $self;
  }
  
  sub meta_meta {
      my $class = shift;
      return $class->_meta_meta
          if $class->can( '_meta_meta' );
  
      my $meta = { index => 1 };
      inject( $class, "_meta_meta", sub { $meta });
      return $meta;
  }
  
  sub package { shift->[0] }
  
  sub set_accessor {
      my $class = shift;
      ($class->meta_meta->{accessor}) = @_;
  }
  
  sub add_hash_metric {
      my $class = shift;
      my ( $metric, %actions ) = @_;
      $class->add_metric(
          $metric,
          \&gen_hash,
          add   => \&default_hash_add,
          get   => \&default_hash_get,
          has   => \&default_hash_has,
          clear => \&default_hash_clear,
          pull  => \&default_hash_pull,
          merge => \&default_hash_merge,
          %actions,
      );
  }
  
  sub add_lists_metric {
      my $class = shift;
      my ( $metric, %actions ) = @_;
      $class->add_metric(
          $metric,
          \&gen_hash,
          push  => \&default_list_push,
          get   => \&default_list_get,
          has   => \&default_list_has,
          clear => \&default_list_clear,
          pull  => \&default_list_pull,
          merge => \&default_list_merge,
          %actions,
      );
  }
  
  sub add_metric {
      my $class = shift;
      my ( $metric, $generator, %actions ) = @_;
      my $meta = $class->meta_meta;
      my $index = $meta->{index}++;
  
      croak "Already tracking metric '$metric'"
          if $meta->{metrics}->{$metric};
  
      $meta->{metrics}->{$metric} = $index;
      $meta->{generators}->[$index] = $generator;
      $meta->{indexes}->{$index} = $metric;
  
      inject( $class, $metric, sub { shift->[$index] });
      $class->add_action( $metric, %actions );
  }
  
  sub add_action {
      my $class = shift;
      my ( $metric, %actions ) = @_;
      $class->_add_action( $metric, $_, $actions{ $_ })
          for keys %actions;
  }
  
  sub _add_action {
      my $class = shift;
      my ( $metric, $action, $code ) = @_;
      croak "You must specify a metric, an action name, and a coderef"
          unless $metric && $action && $code;
  
      my $meta = $class->meta_meta;
      my $name = $class->action_method_name( $metric, $action );
  
      inject( $class, $name, sub {
          my $self = shift;
          my $args = \@_;
          $_->( $self, $self->$metric, $metric, $action, @$args )
              for @{ $meta->{before}->{$name} || [] };
          my @out = $code->( $self, $self->$metric, $metric, $action, @$args );
          $_->( $self, $self->$metric, $metric, $action, @$args )
              for @{ $meta->{after}->{$name} || [] };
          return @out ? (@out > 1 ? @out : $out[0]) : ();
      });
  }
  
  sub action_method_name {
      my $class = shift;
      my ( $metric, $action ) = @_;
      return "$metric\_$action";
  }
  
  sub hook_before {
      my $class = shift;
      my ( $metric, $action, $code ) = @_;
      my $name = $class->action_method_name( $metric, $action );
      push @{ $class->meta_meta->{before}->{$name} } => $code;
  }
  
  sub hook_after {
      my $class = shift;
      my ( $metric, $action, $code ) = @_;
      my $name = $class->action_method_name( $metric, $action );
      push @{ $class->meta_meta->{after}->{$name} } => $code;
  }
  
  sub gen_hash { {} }
  
  sub default_hash_add {
      my $self = shift;
      my ( $data, $metric, $action, $item, @value ) = @_;
      my $name = $self->action_method_name( $metric, $action );
      croak "$name() called without anything to add"
          unless $item;
  
      croak "$name('$item') called without a value to add"
          unless @value;
  
      croak "'$item' already added for metric $metric"
          if $data->{$item};
  
      ($data->{$item}) = @value;
  }
  
  sub default_hash_get {
      my $self = shift;
      my ( $data, $metric, $action, $item ) = @_;
      my $name = $self->action_method_name( $metric, $action );
      croak "$name() called without anything to get"
          unless $item;
  
      # Prevent autovivication
      return exists $data->{$item}
          ? $data->{$item}
          : undef;
  }
  
  sub default_hash_has {
      my $self = shift;
      my ( $data, $metric, $action, $item ) = @_;
      my $name = $self->action_method_name( $metric, $action );
      croak "$name() called without anything to find"
          unless $item;
      return exists $data->{$item} ? 1 : 0;
  }
  
  sub default_hash_clear {
      my $self = shift;
      my ( $data, $metric, $action, $item ) = @_;
      my $name = $self->action_method_name( $metric, $action );
      croak "$name() called without anything to clear"
          unless $item;
      delete $data->{$item};
      return 1;
  }
  
  sub default_hash_pull {
      my $self = shift;
      my ( $data, $metric, $action, $item ) = @_;
      my $name = $self->action_method_name( $metric, $action );
      croak "$name() called without anything to pull"
          unless $item;
      return delete $data->{$item};
  }
  
  sub default_hash_merge {
      my $self = shift;
      my ( $data, $metric, $action, $merge ) = @_;
      for my $key ( keys %$merge ) {
          croak "$key is defined for $metric in both meta-objects"
              if $data->{$key};
          $data->{$key} = $merge->{$key};
      }
  }
  
  sub default_list_push {
      my $self = shift;
      my ( $data, $metric, $action, $item, @values ) = @_;
      my $name = $self->action_method_name( $metric, $action );
      croak "$name() called without an item to which data should be pushed"
          unless $item;
  
      croak "$name('$item') called without values to push"
          unless @values;
  
      push @{$data->{$item}} => @values;
  }
  
  sub default_list_get {
      my $data = default_hash_get(@_);
      return $data ? @$data : ();
  }
  
  sub default_list_has {
      default_hash_has( @_ );
  }
  
  sub default_list_clear {
      default_hash_clear( @_ );
  }
  
  sub default_list_pull {
      my @out = default_list_get( @_ );
      default_list_clear( @_ );
      return @out;
  }
  
  sub default_list_merge {
      my $self = shift;
      my ( $data, $metric, $action, $merge ) = @_;
      for my $key ( keys %$merge ) {
          push @{ $data->{$key} } => @{ $merge->{$key} };
      }
  }
  
  sub merge {
      my $self = shift;
      my ( $merge ) = @_;
      for my $metric ( keys %{ $self->meta_meta->{ metrics }}) {
          my $mergesub = $self->action_method_name( $metric, 'merge' );
          unless( $self->can( $mergesub )) {
              carp "Cannot merge metric '$metric', define a 'merge' action for it.";
              next;
          }
          $self->$mergesub( $merge->$metric );
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Meta::Builder::Base - Base class for Meta::Builder Meta Objects.
  
  =head1 DESCRIPTION
  
  Base class for all L<Meta::Builder> Meta objects. This is where the methods
  used to define new metrics and actions live. This class allows for the creation
  of dynamic meta objects.
  
  =head1 SYNOPSIS
  
  My/Meta.pm:
  
      package My::Meta;
      use strict;
      use warnings;
  
      use base 'Meta::Builder::Base';
  
      # Name the accessor that will be defined in the class that uses the meta object
      # It is used to retrieve the classes meta object.
      __PACKAGE__->set_accessor( "mymeta" );
  
      # Add a metric with two actions
      __PACKAGE__->add_metric(
          mymetric => sub { [] },
          pop => sub {
              my $self = shift;
              my ( $data ) = @_;
              pop @$data;
          },
          push => sub {
              my $self = shift;
              my ( $data, $metric, $action, @args ) = @_;
              push @$data => @args;
          }
      );
  
      # Add an additional action to the metric
      __PACKAGE__->add_action( 'mymetric', get_ref => sub { shift });
  
      # Add some predefined metric types + actions
      __PACKAGE__->add_hash_metric( 'my_hashmetric' );
      __PACKAGE__->add_lists_metric( 'my_listsmetric' );
  
  My.pm:
  
      package My;
      use strict;
      use warnings;
  
      use My::Meta;
  
      My::Meta->new( __PACKAGE__ );
  
      # My::Meta defines mymeta() as the accessor we use to get our meta object.
      # this is the ONLY way to get the meta object for this class.
  
      mymeta()->mymetric_push( "some data" );
      mymeta()->my_hashmetric_add( key => 'value' );
      mymeta()->my_listsmetric_push( list => qw/valueA valueB/ );
  
      # It works fine as an object/class method as well.
      __PACKAGE__->mymeta->do_thing(...);
  
      ...;
  
  =head1 PACKAGE METRIC
  
  Whenever you create a new instance of a meta-object you must provide the name
  of the package to which the meta-object belongs. The 'package' metric will be
  set to this package name, and can be retirved via the 'package' method:
  C<$meta->package()>.
  
  =head1 HASH METRICS
  
  Hash metrics are metrics that hold key/value pairs. A hash metric is defined
  using either the C<hash_metric()> function, or the C<$meta->add_hash_metric()>
  method. The following actions are automatically defined for hash metrics:
  
  =over 4
  
  =item $meta->add_METRIC( $key, $value )
  
  Add a key/value pair to the metric. Will throw an exception if the metric
  already has a value for the specified key.
  
  =item $value = $meta->get_METRIC( $key )
  
  Get the value for a specified key.
  
  =item $bool = $meta->has_METRIC( $key )
  
  Check that the metric has the specified key defined.
  
  =item $meta->clear_METRIC( $key )
  
  Clear the specified key/value pair in the metric. (returns nothing)
  
  =item $value = $meta->pull_METRIC( $key )
  
  Get the value for the specified key, then clear the pair form the metric.
  
  =back
  
  =head1 LISTS METRICS
  
  =over 4
  
  =item $meta->push_METRIC( $key, @values )
  
  Push values into the specified list for the given metric.
  
  =item @values = $meta->get_METRIC( $key )
  
  Get the values for a specified key.
  
  =item $bool = $meta->has_METRIC( $key )
  
  Check that the metric has the specified list.
  
  =item $meta->clear_METRIC( $key )
  
  Clear the specified list in the metric. (returns nothing)
  
  =item @values = $meta->pull_METRIC( $key )
  
  Get the values for the specified list in the metric, then clear the list.
  
  =back
  
  =head1 CLASS METHODS
  
  =over 4
  
  =item $meta = $class->new( $package, %metrics )
  
  Create a new instance of the meta-class, and apply it to $package.
  
  =item $metadata = $class->meta_meta()
  
  Get the meta data for the meta-class itself. (The meta-class is build using
  meta-data)
  
  =item $new_hashref = $class->gen_hash()
  
  Generate a new empty hashref.
  
  =item $name = $class->action_method_name( $metric, $action )
  
  Generate the name of the method for the given metric and action. Override this
  if you do not like the METRIC_ACTION() method names.
  
  =back
  
  =head1 OBJECT METHODS
  
  =over 4
  
  =item $package = $meta->package()
  
  Get the name of the package to which this meta-class applies.
  
  =item $meta->set_accessor( $name )
  
  Set the accessor that is used to retrieve the meta-object from the class to
  which it applies.
  
  =item $meta->add_hash_metric( $metric, %actions )
  
  Add a hash metric (see L</"HASH METRICS">).
  
  %actions should contain C<action =<gt> sub {...}> pairs for constructing
  actions (See add_action()).
  
  =item $meta->add_lists_metric( $metric, %actions )
  
  Add a lists metric (see L</"LISTS METRICS">)
  
  %actions should contain C<action =<gt> sub {...}> pairs for constructing
  actions (See add_action()).
  
  =item $meta->add_metric( $metric, \&generator, %actions )
  
  Add a custom metric. The second argument should be a sub that generates a
  default value for the metric.
  
  %actions should contain C<action =<gt> sub {...}> pairs for constructing
  actions (See add_action()).
  
  =item $meta->add_action( $metric, $action => sub { ... } )
  
  Add an action for the specified metric. See L</"ACTION AND HOOK METHODS"> for
  details on how to write an action coderef.
  
  =item $meta->hook_before( $metric, $action, sub { ... })
  
  Add a hook for the specified metric. See L</"ACTION AND HOOK METHODS"> for
  details on how to write a hook coderef.
  
  =item $meta->hook_after( $metric, $action, sub { ... })
  
  Add a hook for the specified metric. See L</"ACTION AND HOOK METHODS"> for
  details on how to write a hook coderef.
  
  =back
  
  =head1 ACTION AND HOOK METHODS
  
      sub {
          my $self = shift;
          my ( $data, $metric, $action, @args ) = @_;
          ...;
      }
  
  Action and hook methods are called when someone calls
  C<$meta-<gt>metric_action(...)>. First all before hooks will be called, the the
  action itself, and finally the after hooks will be called. All methods in the
  chain get the exact same unaltered arguments. Only the main action sub can
  return anything.
  
  Arguments are:
  
  =over 4
  
  =item 0: $self
  
  These are methods, so the first argument is the meta object itself.
  
  =item 1: $data
  
  This is the data structure stored for the metric. This is the same as calling
  $meta->metric()
  
  =item 2: $metric
  
  Name of the metric
  
  =item 3: $action
  
  Name of the action
  
  =item 4+: @args
  
  Arguments that metric_action() was called with.
  
  =back
  
  =head1 DEFAULT ACTION METHODS
  
  There are the default action methods used by hashmetrics and listsmetrics.
  
  =over 4
  
  =item $meta->default_hash_add( $data, $metric, $action, $item, $value )
  
  =item $value = $meta->default_hash_get( $data, $metric, $action, $item )
  
  =item $bool = $meta->default_hash_has( $data, $metric, $action, $item )
  
  =item $meta->default_hash_clear( $data, $metric, $action, $item )
  
  =item $value = $meta->default_hash_pull( $data, $metric, $action, $item )
  
  =item $meta->default_list_push( $data, $metric, $action, $item, @values )
  
  =item @values = $meta->default_list_get( $data, $metric, $action, $item )
  
  =item $bool = $meta->default_list_has( $data, $metric, $action, $item )
  
  =item $meta->default_list_clear( $data, $metric, $action, $item )
  
  =item @values = $meta->default_list_pull( $data, $metric, $action, $item )
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Meta-Builder is free software; Standard perl licence.
  
  Meta-Builder is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  FOR A PARTICULAR PURPOSE.  See the license for more details.
META_BUILDER_BASE

$fatpacked{"Meta/Builder/Util.pm"} = <<'META_BUILDER_UTIL';
  package Meta::Builder::Util;
  use strict;
  use warnings;
  
  sub import {
      my $class = shift;
      my $caller = caller;
      inject( $caller, "inject", \&inject );
  }
  
  sub inject {
      my ( $class, $sub, $code, $nowarn ) = @_;
      if ( $nowarn ) {
          no strict 'refs';
          no warnings 'redefine';
          *{"$class\::$sub"} = $code;
      }
      else {
          no strict 'refs';
          *{"$class\::$sub"} = $code;
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Meta::Builder::Util - Utility functions for Meta::Builder
  
  =head1 EXPORTS
  
  =over 4
  
  =item inject( $class, $name, $code, $redefine )
  
  used to inject a sub into a namespace.
  
  =back
  
  =head1 AUTHORS
  
  Chad Granum L<exodist7@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2010 Chad Granum
  
  Meta-Builder is free software; Standard perl licence.
  
  Meta-Builder is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  FOR A PARTICULAR PURPOSE.  See the license for more details.
META_BUILDER_UTIL

$fatpacked{"Method/Generate/Accessor.pm"} = <<'METHOD_GENERATE_ACCESSOR';
  package Method::Generate::Accessor;
  
  use strictures 1;
  use Moo::_Utils;
  use base qw(Moo::Object);
  use Sub::Quote;
  use B 'perlstring';
  BEGIN {
    our $CAN_HAZ_XS =
      !$ENV{MOO_XS_DISABLE}
        &&
      _maybe_load_module('Class::XSAccessor')
        &&
      (Class::XSAccessor->VERSION > 1.06)
    ;
  }
  
  sub generate_method {
    my ($self, $into, $name, $spec, $quote_opts) = @_;
    die "Must have an is" unless my $is = $spec->{is};
    if ($is eq 'ro') {
      $spec->{reader} = $name unless exists $spec->{reader};
    } elsif ($is eq 'rw') {
      $spec->{accessor} = $name unless exists $spec->{accessor};
    } elsif ($is eq 'lazy') {
      $spec->{init_arg} = undef unless exists $spec->{init_arg};
      $spec->{reader} = $name unless exists $spec->{reader};
      $spec->{lazy} = 1;
      $spec->{builder} ||= '_build_'.$name unless $spec->{default};
    } elsif ($is ne 'bare') {
      die "Unknown is ${is}";
    }
    my %methods;
    if (my $reader = $spec->{reader}) {
      if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
        $methods{$reader} = $self->_generate_xs(
          getters => $into, $reader, $name
        );
      } else {
        $self->{captures} = {};
        $methods{$reader} =
          quote_sub "${into}::${reader}"
            => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
               .$self->_generate_get($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $accessor = $spec->{accessor}) {
      if (
        our $CAN_HAZ_XS
        && $self->is_simple_get($name, $spec)
        && $self->is_simple_set($name, $spec)
      ) {
        $methods{$accessor} = $self->_generate_xs(
          accessors => $into, $accessor, $name
        );
      } else {
        $self->{captures} = {};
        $methods{$accessor} =
          quote_sub "${into}::${accessor}"
            => $self->_generate_getset($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $writer = $spec->{writer}) {
      if (
        our $CAN_HAZ_XS
        && $self->is_simple_set($name, $spec)
      ) {
        $methods{$writer} = $self->_generate_xs(
          setters => $into, $writer, $name
        );
      } else {
        $self->{captures} = {};
        $methods{$writer} =
          quote_sub "${into}::${writer}"
            => $self->_generate_set($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $pred = $spec->{predicate}) {
      $methods{$pred} =
        quote_sub "${into}::${pred}" =>
          '    '.$self->_generate_simple_has('$_[0]', $name)."\n"
        ;
    }
    if (my $cl = $spec->{clearer}) {
      $methods{$cl} =
        quote_sub "${into}::${cl}" => 
          "    delete \$_[0]->{${\perlstring $name}}\n"
        ;
    }
    if (my $hspec = $spec->{handles}) {
      my $asserter = $spec->{asserter} ||= '_assert_'.$name;
      my @specs = do {
        if (ref($hspec) eq 'ARRAY') {
          map [ $_ => $_ ], @$hspec;
        } elsif (ref($hspec) eq 'HASH') {
          map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
            keys %$hspec;
        } elsif (!ref($hspec)) {
          map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
        } else {
          die "You gave me a handles of ${hspec} and I have no idea why";
        }
      };
      foreach my $spec (@specs) {
        my ($proxy, $target, @args) = @$spec;
        $self->{captures} = {};
        $methods{$proxy} =
          quote_sub "${into}::${proxy}" =>
            $self->_generate_delegation($asserter, $target, \@args),
            delete $self->{captures}
          ;
      }
    }
    if (my $asserter = $spec->{asserter}) {
      $self->{captures} = {};
      $methods{$asserter} =
        quote_sub "${into}::${asserter}" =>
          'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
          delete $self->{captures}
        ;
    }
    \%methods;
  }
  
  sub is_simple_attribute {
    my ($self, $name, $spec) = @_;
    # clearer doesn't have to be listed because it doesn't
    # affect whether defined/exists makes a difference
    !grep $spec->{$_},
      qw(lazy default builder coerce isa trigger predicate weak_ref);
  }
  
  sub is_simple_get {
    my ($self, $name, $spec) = @_;
    !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
  }
  
  sub is_simple_set {
    my ($self, $name, $spec) = @_;
    !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
  }
  
  sub has_eager_default {
    my ($self, $name, $spec) = @_;
    (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
  }
  
  sub _generate_get {
    my ($self, $name, $spec) = @_;
    my $simple = $self->_generate_simple_get('$_[0]', $name);
    if ($self->is_simple_get($name, $spec)) {
      $simple;
    } else {
      'do { '.$self->_generate_use_default(
        '$_[0]', $name, $spec,
        $self->_generate_simple_has('$_[0]', $name),
      ).'; '.$simple.' }';
    }
  }
  
  sub _generate_simple_has {
    my ($self, $me, $name) = @_;
    "exists ${me}->{${\perlstring $name}}";
  }
  
  sub generate_get_default {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_get_default(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_use_default {
    my ($self, $me, $name, $spec, $test) = @_;
    $self->_generate_simple_set(
      $me, $name, $spec, $self->_generate_get_default($me, $name, $spec)
    ).' unless '.$test;
  }
  
  sub _generate_get_default {
    my ($self, $me, $name, $spec) = @_;
    $spec->{default}
      ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
      : "${me}->${\$spec->{builder}}"
  }
  
  sub generate_simple_get {
    my ($self, @args) = @_;
    $self->_generate_simple_get(@args);
  }
  
  sub _generate_simple_get {
    my ($self, $me, $name) = @_;
    my $name_str = perlstring $name;
    "${me}->{${name_str}}";
  }
  
  sub _generate_set {
    my ($self, $name, $spec) = @_;
    if ($self->is_simple_set($name, $spec)) {
      $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
    } else {
      my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
      my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
      my $code = "do { my (\$self, \$value) = \@_;\n";
      if ($coerce) {
        $code .=
          "        \$value = "
          .$self->_generate_coerce($name, '$self', '$value', $coerce).";\n";
      }
      if ($isa_check) {
        $code .= 
          "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
      }
      if ($trigger) {
        my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
        $code .=
          "        ".$simple.";\n        ".$fire.";\n"
          ."        \$value;\n";
      } else {
        $code .= "        ".$simple.";\n";
      }
      $code .= "      }";
      $code;
    }
  }
  
  sub generate_coerce {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_coerce(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_coerce {
    my ($self, $name, $obj, $value, $coerce) = @_;
    $self->_generate_call_code($name, 'coerce', "${value}", $coerce);
  }
   
  sub generate_trigger {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_trigger(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_trigger {
    my ($self, $name, $obj, $value, $trigger) = @_;
    $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
  }
  
  sub generate_isa_check {
    my ($self, @args) = @_;
    $self->{captures} = {};
    my $code = $self->_generate_isa_check(@args);
    ($code, delete $self->{captures});
  }
  
  sub _generate_isa_check {
    my ($self, $name, $value, $check) = @_;
    $self->_generate_call_code($name, 'isa_check', $value, $check);
  }
  
  sub _generate_call_code {
    my ($self, $name, $type, $values, $sub) = @_;
    if (my $quoted = quoted_from_sub($sub)) {
      my $code = $quoted->[1];
      my $at_ = '@_ = ('.$values.');';
      if (my $captures = $quoted->[2]) {
        my $cap_name = qq{\$${type}_captures_for_${name}};
        $self->{captures}->{$cap_name} = \$captures;
        Sub::Quote::inlinify(
          $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6)
        );
      } else {
        Sub::Quote::inlinify($code, $values);
      }
    } else {
      my $cap_name = qq{\$${type}_for_${name}};
      $self->{captures}->{$cap_name} = \$sub;
      "${cap_name}->(${values})";
    }
  }
  
  sub generate_populate_set {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_populate_set(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_populate_set {
    my ($self, $me, $name, $spec, $source, $test) = @_;
    if ($self->has_eager_default($name, $spec)) {
      my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
      my $get_default = $self->_generate_get_default(
                          '$new', $_, $spec
                        );
      my $get_value = 
        defined($spec->{init_arg})
          ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
              .$get_default
              ."\n${get_indent})"
          : $get_default;
      if ( $spec->{coerce} ) {
          $get_value = $self->_generate_coerce(
              $name, $me, $get_value,
              $spec->{coerce}
            )
      }
      ($spec->{isa}
        ? "    {\n      my \$value = ".$get_value.";\n      "
          .$self->_generate_isa_check(
            $name, '$value', $spec->{isa}
          ).";\n"
          .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
          ."    }\n"
        : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
      )
      .($spec->{trigger}
        ? '    '
          .$self->_generate_trigger(
            $name, $me, $self->_generate_simple_get($me, $name),
            $spec->{trigger}
          )." if ${test};\n"
        : ''
      );
    } else {
      "    if (${test}) {\n"
        .($spec->{coerce}
          ? "      $source = "
            .$self->_generate_coerce(
              $name, $me, $source,
              $spec->{coerce}
            ).";\n"
          : ""
        )
        .($spec->{isa}
          ? "      "
            .$self->_generate_isa_check(
              $name, $source, $spec->{isa}
            ).";\n"
          : ""
        )
        ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
        .($spec->{trigger}
          ? "      "
            .$self->_generate_trigger(
              $name, $me, $self->_generate_simple_get($me, $name),
              $spec->{trigger}
            ).";\n"
          : ""
        )
        ."    }\n";
    }
  }
  
  sub generate_multi_set {
    my ($self, $me, $to_set, $from) = @_;
    "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
  }
  
  sub _generate_simple_set {
    my ($self, $me, $name, $spec, $value) = @_;
    my $name_str = perlstring $name;
    my $simple = "${me}->{${name_str}} = ${value}";
  
    if ($spec->{weak_ref}) {
      { local $@; require Scalar::Util; }
  
      # Perl < 5.8.3 can't weaken refs to readonly vars
      # (e.g. string constants). This *can* be solved by:
      #
      #Internals::SetReadWrite($foo);
      #Scalar::Util::weaken ($foo);
      #Internals::SetReadOnly($foo);
      #
      # but requires XS and is just too damn crazy
      # so simply throw a better exception
      Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
  
        eval { Scalar::Util::weaken($simple); 1 } or do {
          if( \$@ =~ /Modification of a read-only value attempted/) {
            { local $@; require Carp; }
            Carp::croak( sprintf (
              'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
              $name_str,
            ) );
          } else {
            die \$@;
          }
        };
  EOC
    } else {
      $simple;
    }
  }
  
  sub _generate_getset {
    my ($self, $name, $spec) = @_;
    q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
      ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
  }
  
  sub _generate_delegation {
    my ($self, $asserter, $target, $args) = @_;
    my $arg_string = do {
      if (@$args) {
        # I could, I reckon, linearise out non-refs here using perlstring
        # plus something to check for numbers but I'm unsure if it's worth it
        $self->{captures}{'@curries'} = $args;
        '@curries, @_';
      } else {
        '@_';
      }
    };
    "shift->${asserter}->${target}(${arg_string});";
  }
  
  sub _generate_xs {
    my ($self, $type, $into, $name, $slot) = @_;
    Class::XSAccessor->import(
      class => $into,
      $type => { $name => $slot }
    );
    $into->can($name);
  }
  
  1;
METHOD_GENERATE_ACCESSOR

$fatpacked{"Method/Generate/BuildAll.pm"} = <<'METHOD_GENERATE_BUILDALL';
  package Method::Generate::BuildAll;
  
  use strictures 1;
  use base qw(Moo::Object);
  use Sub::Quote;
  use Moo::_Utils;
  use B 'perlstring';
  
  sub generate_method {
    my ($self, $into) = @_;
    quote_sub "${into}::BUILDALL", join '',
      $self->_handle_subbuild($into),
      qq{    my \$self = shift;\n},
      $self->buildall_body_for($into, '$self', '@_'),
      qq{    return \$self\n};
  }
  
  sub _handle_subbuild {
    my ($self, $into) = @_;
    '    if (ref($_[0]) ne '.perlstring($into).') {'."\n".
    '      return shift->Moo::Object::BUILDALL(@_)'.";\n".
    '    }'."\n";
  }
  
  sub buildall_body_for {
    my ($self, $into, $me, $args) = @_;
    my @builds =
      grep *{_getglob($_)}{CODE},
      map "${_}::BUILD",
      reverse @{Moo::_Utils::_get_linear_isa($into)};
    join '', map qq{    ${me}->${_}(${args});\n}, @builds;
  }
  
  1;
METHOD_GENERATE_BUILDALL

$fatpacked{"Method/Generate/Constructor.pm"} = <<'METHOD_GENERATE_CONSTRUCTOR';
  package Method::Generate::Constructor;
  
  use strictures 1;
  use Sub::Quote;
  use base qw(Moo::Object);
  use Sub::Defer;
  use B 'perlstring';
  
  sub register_attribute_specs {
    my ($self, %spec) = @_;
    @{$self->{attribute_specs}||={}}{keys %spec} = values %spec;
    $self;
  }
  
  sub all_attribute_specs {
    $_[0]->{attribute_specs}
  }
  
  sub accessor_generator {
    $_[0]->{accessor_generator}
  }
  
  sub construction_string {
    my ($self) = @_;
    $self->{construction_string} or 'bless({}, $class);'
  }
  
  sub install_delayed {
    my ($self) = @_;
    my $package = $self->{package};
    defer_sub "${package}::new" => sub {
      unquote_sub $self->generate_method(
        $package, 'new', $self->{attribute_specs}, { no_install => 1 }
      )
    };
    $self;
  }
  
  sub generate_method {
    my ($self, $into, $name, $spec, $quote_opts) = @_;
    foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
      $spec->{$no_init}{init_arg} = $no_init;
    }
    local $self->{captures} = {};
    my $body = '    my $class = shift;'."\n"
              .'    $class = ref($class) if ref($class);'."\n";
    $body .= $self->_handle_subconstructor($into, $name);
    my $into_buildargs = $into->can('BUILDARGS');
    if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) {
        $body .= $self->_generate_args_via_buildargs;
    } else {
        $body .= $self->_generate_args;
    }
    $body .= $self->_check_required($spec);
    $body .= '    my $new = '.$self->construction_string.";\n";
    $body .= $self->_assign_new($spec);
    if ($into->can('BUILD')) {
      { local $@; require Method::Generate::BuildAll; }
      $body .= Method::Generate::BuildAll->new->buildall_body_for(
        $into, '$new', '$args'
      );
    }
    $body .= '    return $new;'."\n";
    if ($into->can('DEMOLISH')) {
      { local $@; require Method::Generate::DemolishAll; }
      Method::Generate::DemolishAll->new->generate_method($into);
    }
    quote_sub
      "${into}::${name}" => $body,
      $self->{captures}, $quote_opts||{}
    ;
  }
  
  sub _handle_subconstructor {
    my ($self, $into, $name) = @_;
    if (my $gen = $self->{subconstructor_generator}) {
      '    if ($class ne '.perlstring($into).') {'."\n".
      '      '.$gen.";\n".
      '      return $class->'.$name.'(@_)'.";\n".
      '    }'."\n";
    } else {
      ''
    }
  }
  
  sub _cap_call {
    my ($self, $code, $captures) = @_;
    @{$self->{captures}}{keys %$captures} = values %$captures if $captures;
    $code;
  }
  
  sub _generate_args_via_buildargs {
    my ($self) = @_;
    q{    my $args = $class->BUILDARGS(@_);}."\n";
  }
  
  # inlined from Moo::Object - update that first.
  sub _generate_args {
    my ($self) = @_;
    return <<'_EOA';
      my $args;
      if ( scalar @_ == 1 ) {
          unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
              die "Single parameters to new() must be a HASH ref"
                  ." data => ". $_[0] ."\n";
          }
          $args = { %{ $_[0] } };
      }
      elsif ( @_ % 2 ) {
          die "The new() method for $class expects a hash reference or a key/value list."
                  . " You passed an odd number of arguments\n";
      }
      else {
          $args = {@_};
      }
  _EOA
  
  }
  
  sub _assign_new {
    my ($self, $spec) = @_;
    my (@init, @slots, %test);
    my $ag = $self->accessor_generator;
    NAME: foreach my $name (sort keys %$spec) {
      my $attr_spec = $spec->{$name};
      unless ($ag->is_simple_attribute($name, $attr_spec)) {
        next NAME unless defined($attr_spec->{init_arg})
                           or $ag->has_eager_default($name, $attr_spec);
        $test{$name} = $attr_spec->{init_arg};
        next NAME;
      }
      next NAME unless defined(my $i = $attr_spec->{init_arg});
      push @init, $i;
      push @slots, $name;
    }
    return '' unless @init or %test;
    join '', (
      @init
        ? '    '.$self->_cap_call($ag->generate_multi_set(
            '$new', [ @slots ], '@{$args}{qw('.join(' ',@init).')}'
          )).";\n"
        : ''
    ), map {
      my $arg_key = perlstring($test{$_});
      my $test = "exists \$args->{$arg_key}";
      my $source = "\$args->{$arg_key}";
      my $attr_spec = $spec->{$_};
      $self->_cap_call($ag->generate_populate_set(
        '$new', $_, $attr_spec, $source, $test
      ));
    } sort keys %test;
  }
  
  sub _check_required {
    my ($self, $spec) = @_;
    my @required_init =
      map $spec->{$_}{init_arg},
        grep $spec->{$_}{required},
          sort keys %$spec;
    return '' unless @required_init;
    '    if (my @missing = grep !exists $args->{$_}, qw('
      .join(' ',@required_init).')) {'."\n"
      .q{      die "Missing required arguments: ".join(', ', sort @missing);}."\n"
      ."    }\n";
  }
  
  sub _check_isa {
    my ($self, $spec) = @_;
    my $acc = $self->accessor_generator;
    my $captures = $self->{captures};
    my $check = '';
    foreach my $name (sort keys %$spec) {
      my ($init, $isa) = @{$spec->{$name}}{qw(init_arg isa)};
      next unless $init and $isa;
      my $init_str = perlstring($init);
      my ($code, $add_captures) = $acc->generate_isa_check(
        $name, "\$args->{${init_str}}", $isa
      );
      @{$captures}{keys %$add_captures} = values %$add_captures;
      $check .= "    ${code}".(
        (not($spec->{lazy}) and ($spec->{default} or $spec->{builder})
          ? ";\n"
          : "if exists \$args->{${init_str}};\n"
        )
      );
    }
    return $check;
  }
  
  sub _fire_triggers {
    my ($self, $spec) = @_;
    my $acc = $self->accessor_generator;
    my $captures = $self->{captures};
    my $fire = '';
    foreach my $name (sort keys %$spec) {
      my ($init, $trigger) = @{$spec->{$name}}{qw(init_arg trigger)};
      next unless $init && $trigger;
      my ($code, $add_captures) = $acc->generate_trigger(
        $name, '$new', $acc->generate_simple_get('$new', $name), $trigger
      );
      @{$captures}{keys %$add_captures} = values %$add_captures;
      $fire .= "    ${code} if exists \$args->{${\perlstring $init}};\n";
    }
    return $fire;
  }
  
  1;
METHOD_GENERATE_CONSTRUCTOR

$fatpacked{"Method/Generate/DemolishAll.pm"} = <<'METHOD_GENERATE_DEMOLISHALL';
  package Method::Generate::DemolishAll;
  
  use strictures 1;
  use base qw(Moo::Object);
  use Sub::Quote;
  use Moo::_Utils;
  use B qw(perlstring);
  
  sub generate_method {
    my ($self, $into) = @_;
    quote_sub "${into}::DEMOLISHALL", join '',
      $self->_handle_subdemolish($into),
      qq{    my \$self = shift;\n},
      $self->demolishall_body_for($into, '$self', '@_'),
      qq{    return \$self\n};
    quote_sub "${into}::DESTROY", join '',
      q!    my $self = shift;
      my $e = do {
        local $?;
        local $@;
        require Moo::_Utils;
        eval {
          $self->DEMOLISHALL($Moo::_Utils::_in_global_destruction);
        };
        $@;
      };
    
      no warnings 'misc';
      die $e if $e; # rethrow
    !;
  }
  
  sub demolishall_body_for {
    my ($self, $into, $me, $args) = @_;
    my @demolishers =
      grep *{_getglob($_)}{CODE},
      map "${_}::DEMOLISH",
      @{Moo::_Utils::_get_linear_isa($into)};
    join '', map qq{    ${me}->${_}(${args});\n}, @demolishers;
  }
  
  sub _handle_subdemolish {
    my ($self, $into) = @_;
    '    if (ref($_[0]) ne '.perlstring($into).') {'."\n".
    '      return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
    '    }'."\n";
  }
  
  1;
METHOD_GENERATE_DEMOLISHALL

$fatpacked{"Method/Inliner.pm"} = <<'METHOD_INLINER';
  package Method::Inliner;
  
  use strictures 1;
  use Text::Balanced qw(extract_bracketed);
  use Sub::Quote ();
  
  sub slurp { do { local (@ARGV, $/) = $_[0]; <> } }
  sub splat {
    open my $out, '>', $_[1] or die "can't open $_[1]: $!";
    print $out $_[0] or die "couldn't write to $_[1]: $!";
  }
  
  sub inlinify {
    my $file = $_[0];
    my @chunks = split /(^sub.*?^}$)/sm, slurp $file;
    warn join "\n--\n", @chunks;
    my %code;
    foreach my $chunk (@chunks) {
      if (my ($name, $body) =
        $chunk =~ /^sub (\S+) {\n(.*)\n}$/s
      ) {
        $code{$name} = $body;
      }
    }
    foreach my $chunk (@chunks) {
      my ($me) = $chunk =~ /^sub.*{\n  my \((\$\w+).*\) = \@_;\n/ or next;
      my $meq = quotemeta $me;
      #warn $meq, $chunk;
      my $copy = $chunk;
      my ($fixed, $rest);
      while ($copy =~ s/^(.*?)${meq}->(\S+)(?=\()//s) {
        my ($front, $name) = ($1, $2);
        ((my $body), $rest) = extract_bracketed($copy, '()');
        warn "spotted ${name} - ${body}";
        if ($code{$name}) {
        warn "replacing";
          s/^\(//, s/\)$// for $body;
          $body = "${me}, ".$body;
          $fixed .= $front.Sub::Quote::inlinify($code{$name}, $body);
        } else {
  	$fixed .= $front.$me.'->'.$name.$body;
        }
        #warn $fixed; warn $rest;
        $copy = $rest;
      }
      $fixed .= $rest if $fixed;
      warn $fixed if $fixed;
      $chunk = $fixed if $fixed;
    }
    print join '', @chunks;
  }
  
  1;
METHOD_INLINER

$fatpacked{"Moo.pm"} = <<'MOO';
  package Moo;
  
  use strictures 1;
  use Moo::_Utils;
  use B 'perlstring';
  
  our $VERSION = '0.009012'; # 0.9.12
  $VERSION = eval $VERSION;
  
  our %MAKERS;
  
  sub import {
    my $target = caller;
    my $class = shift;
    strictures->import;
    return if $MAKERS{$target}; # already exported into this package
    *{_getglob("${target}::extends")} = sub {
      _load_module($_) for @_;
      # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
      @{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
    };
    *{_getglob("${target}::with")} = sub {
      { local $@; require Moo::Role; }
      die "Only one role supported at a time by with" if @_ > 1;
      Moo::Role->apply_role_to_package($target, $_[0]);
    };
    $MAKERS{$target} = {};
    *{_getglob("${target}::has")} = sub {
      my ($name, %spec) = @_;
      ($MAKERS{$target}{accessor} ||= do {
        { local $@; require Method::Generate::Accessor; }
        Method::Generate::Accessor->new
      })->generate_method($target, $name, \%spec);
      $class->_constructor_maker_for($target)
            ->register_attribute_specs($name, \%spec);
    };
    foreach my $type (qw(before after around)) {
      *{_getglob "${target}::${type}"} = sub {
        { local $@; require Class::Method::Modifiers; }
        _install_modifier($target, $type, @_);
      };
    }
    {
      no strict 'refs';
      @{"${target}::ISA"} = do {
        {; local $@; require Moo::Object; } ('Moo::Object');
      } unless @{"${target}::ISA"};
    }
  }
  
  sub _constructor_maker_for {
    my ($class, $target, $select_super) = @_;
    return unless $MAKERS{$target};
    $MAKERS{$target}{constructor} ||= do {
      {
        local $@;
        require Method::Generate::Constructor;
        require Sub::Defer;
      }
      my ($moo_constructor, $con);
  
      if ($select_super && $MAKERS{$select_super}) {
        $moo_constructor = 1;
        $con = $MAKERS{$select_super}{constructor};
      } else {
        my $t_new = $target->can('new');
        if ($t_new) {
          if ($t_new == Moo::Object->can('new')) {
            $moo_constructor = 1;
          } elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) {
            my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
            if ($MAKERS{$pkg}) {
              $moo_constructor = 1;
              $con = $MAKERS{$pkg}{constructor};
            }
          }
        } else {
          $moo_constructor = 1; # no other constructor, make a Moo one
        }
      };
      Method::Generate::Constructor
        ->new(
          package => $target,
          accessor_generator => do {
            { local $@; require Method::Generate::Accessor; }
            Method::Generate::Accessor->new;
          },
          construction_string => (
            $moo_constructor
              ? ($con ? $con->construction_string : undef)
              : ('$class->'.$target.'::SUPER::new(@_)')
          ),
          subconstructor_generator => (
            $class.'->_constructor_maker_for($class,'.perlstring($target).')'
          ),
        )
        ->install_delayed
        ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
    }
  }
  
  1;
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  Moo - Minimalist Object Orientation (with Moose compatiblity)
  
  =head1 SYNOPSIS
  
   package Cat::Food;
  
   use Moo;
   use Sub::Quote;
  
   sub feed_lion {
     my $self = shift;
     my $amount = shift || 1;
  
     $self->pounds( $self->pounds - $amount );
   }
  
   has taste => (
     is => 'ro',
   );
  
   has brand => (
     is  => 'ro',
     isa => sub {
       die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ'
     },
  );
  
   has pounds => (
     is  => 'rw',
     isa => quote_sub q{ die "$_[0] is too much cat food!" unless $_[0] < 15 },
   );
  
   1;
  
  and else where
  
   my $full = Cat::Food->new(
      taste  => 'DELICIOUS.',
      brand  => 'SWEET-TREATZ',
      pounds => 10,
   );
  
   $full->feed_lion;
  
   say $full->pounds;
  
  =head1 DESCRIPTION
  
  This module is an extremely light-weight, high-performance L<Moose> replacement.
  It also avoids depending on any XS modules to allow simple deployments.  The
  name C<Moo> is based on the idea that it provides almost -but not quite- two
  thirds of L<Moose>.
  
  Unlike C<Mouse> this module does not aim at full L<Moose> compatibility.  See
  L</INCOMPATIBILITIES> for more details.
  
  =head1 WHY MOO EXISTS
  
  If you want a full object system with a rich Metaprotocol, L<Moose> is
  already wonderful.
  
  I've tried several times to use L<Mouse> but it's 3x the size of Moo and
  takes longer to load than most of my Moo based CGI scripts take to run.
  
  If you don't want L<Moose>, you don't want "less metaprotocol" like L<Mouse>,
  you want "as little as possible" - which means "no metaprotocol", which is
  what Moo provides.
  
  By Moo 1.0 I intend to have Moo's equivalent of L<Any::Moose> built in -
  if Moose gets loaded, any Moo class or role will act as a Moose equivalent
  if treated as such.
  
  Hence - Moo exists as its name - Minimal Object Orientation - with a pledge
  to make it smooth to upgrade to L<Moose> when you need more than minimal
  features.
  
  =head1 IMPORTED METHODS
  
  =head2 new
  
   Foo::Bar->new( attr1 => 3 );
  
  or
  
   Foo::Bar->new({ attr1 => 3 });
  
  =head2 BUILDARGS
  
   around BUILDARGS => sub {
     my $orig = shift;
     my ( $class, @args ) = @_;
  
     unshift @args, "attr1" if @args % 2 == 1;
  
     return $class->$orig(@args);
   };
  
   Foo::Bar->new( 3 );
  
  The default implementation of this method accepts a hash or hash reference of
  named parameters. If it receives a single argument that isn't a hash reference
  it throws an error.
  
  You can override this method in your class to handle other types of options
  passed to the constructor.
  
  This method should always return a hash reference of named options.
  
  =head2 BUILDALL
  
  Don't override (or probably even call) this method.  Instead, you can define
  a C<BUILD> method on your class and the constructor will automatically call the
  C<BUILD> method from parent down to child after the object has been
  instantiated.  Typically this is used for object validation or possibly logging.
  
  =head2 DESTROY
  
  If you have a C<DEMOLISH> method anywhere in your inheritance hierarchy,
  a C<DESTROY> method is created on first object construction which will call
  C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
  method from child upwards to parents.
  
  Note that the C<DESTROY> method is created on first construction of an object
  of your class in order to not add overhead to classes without C<DEMOLISH>
  methods; this may prove slightly surprising if you try and define your own.
  
  =head2 does
  
   if ($foo->does('Some::Role1')) {
     ...
   }
  
  Returns true if the object composes in the passed role.
  
  =head1 IMPORTED SUBROUTINES
  
  =head2 extends
  
   extends 'Parent::Class';
  
  Declares base class. Multiple superclasses can be passed for multiple
  inheritance (but please use roles instead).
  
  Calling extends more than once will REPLACE your superclasses, not add to
  them like 'use base' would.
  
  =head2 with
  
   with 'Some::Role1';
   with 'Some::Role2';
  
  Composes a L<Role::Tiny> into current class.  Only one role may be composed in
  at a time to allow the code to remain as simple as possible.
  
  =head2 has
  
   has attr => (
     is => 'ro',
   );
  
  Declares an attribute for the class.
  
  The options for C<has> are as follows:
  
  =over 2
  
  =item * is
  
  B<required>, must be C<ro> or C<rw>.  Unsurprisingly, C<ro> generates an
  accessor that will not respond to arguments; to be clear: a getter only. C<rw>
  will create a perlish getter/setter.
  
  =item * isa
  
  Takes a coderef which is meant to validate the attribute.  Unlike L<Moose> Moo
  does not include a basic type system, so instead of doing C<< isa => 'Num' >>,
  one should do
  
   isa => quote_sub q{
     die "$_[0] is not a number!" unless looks_like_number $_[0]
   },
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * coerce
  
  Takes a coderef which is meant to coerce the attribute.  The basic idea is to
  do something like the following:
  
   coerce => quote_sub q{
     $_[0] + 1 unless $_[0] % 2
   },
  
  Coerce does not require C<isa> to be defined.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * trigger
  
  Takes a coderef which will get called any time the attribute is set. Coderef
  will be invoked against the object with the new value as an argument.
  
  Note that Moose also passes the old value, if any; this feature is not yet
  supported.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * default
  
  Takes a coderef which will get called with $self as its only argument
  to populate an attribute if no value is supplied to the constructor - or
  if the attribute is lazy, when the attribute is first retrieved if no
  value has yet been provided.
  
  Note that if your default is fired during new() there is no guarantee that
  other attributes have been populated yet so you should not rely on their
  existence.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * predicate
  
  Takes a method name which will return true if an attribute has a value.
  
  A common example of this would be to call it C<has_$foo>, implying that the
  object has a C<$foo> set.
  
  =item * builder
  
  Takes a method name which will be called to create the attribute - functions
  exactly like default except that instead of calling
  
    $default->($self);
  
  Moo will call
  
    $self->$builder;
  
  =item * clearer
  
  Takes a method name which will clear the attribute.
  
  =item * lazy
  
  B<Boolean>.  Set this if you want values for the attribute to be grabbed
  lazily.  This is usually a good idea if you have a L</builder> which requires
  another attribute to be set.
  
  =item * required
  
  B<Boolean>.  Set this if the attribute must be passed on instantiation.
  
  =item * reader
  
  The value of this attribute will be the name of the method to get the value of
  the attribute.  If you like Java style methods, you might set this to
  C<get_foo>
  
  =item * writer
  
  The value of this attribute will be the name of the method to set the value of
  the attribute.  If you like Java style methods, you might set this to
  C<set_foo>
  
  =item * weak_ref
  
  B<Boolean>.  Set this if you want the reference that the attribute contains to
  be weakened; use this when circular references are possible, which will cause
  leaks.
  
  =item * init_arg
  
  Takes the name of the key to look for at instantiation time of the object.  A
  common use of this is to make an underscored attribute have a non-underscored
  initialization name. C<undef> means that passing the value in on instantiation
  
  =back
  
  =head2 before
  
   before foo => sub { ... };
  
  See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full
  documentation.
  
  =head2 around
  
   around foo => sub { ... };
  
  See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full
  documentation.
  
  =head2 after
  
   after foo => sub { ... };
  
  See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full
  documentation.
  
  =head1 SUB QUOTE AWARE
  
  L<Sub::Quote/quote_sub> allows us to create coderefs that are "inlineable,"
  giving us a handy, XS-free speed boost.  Any option that is L<Sub::Quote>
  aware can take advantage of this.
  
  =head1 INCOMPATIBILITIES WITH MOOSE
  
  You can only compose one role at a time.  If your application is large or
  complex enough to warrant complex composition, you wanted L<Moose>.
  
  There is no complex type system.  C<isa> is verified with a coderef, if you
  need complex types, just make a library of coderefs, or better yet, functions
  that return quoted subs.
  
  C<initializer> is not supported in core since the author considers it to be a
  bad idea but may be supported by an extension in future.
  
  There is no meta object.  If you need this level of complexity you wanted
  L<Moose> - Moo succeeds at being small because it explicitly does not
  provide a metaprotocol.
  
  No support for C<super>, C<override>, C<inner>, or C<augment> - override can
  be handled by around albeit with a little more typing, and the author considers
  augment to be a bad idea.
  
  L</default> only supports coderefs, because doing otherwise is usually a
  mistake anyway.
  
  C<lazy_build> is not supported per se, but of course it will work if you
  manually set all the options it implies.
  
  C<auto_deref> is not supported since the author considers it a bad idea.
  
  C<documentation> is not supported since it's a very poor replacement for POD.
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
  
  frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
  
  hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org>
  
  jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com>
  
  ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
  
  chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
  
  ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org>
  
  doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010-2011 the Moo L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
MOO

$fatpacked{"Moo/Object.pm"} = <<'MOO_OBJECT';
  package Moo::Object;
  
  use strictures 1;
  
  our %NO_BUILD;
  our %NO_DEMOLISH;
  our $BUILD_MAKER;
  our $DEMOLISH_MAKER;
  
  sub new {
    my $class = shift;
    unless (exists $NO_DEMOLISH{$class}) {
      unless ($NO_DEMOLISH{$class} = !$class->can('DEMOLISH')) {
        ($DEMOLISH_MAKER ||= do {
          { local $@; require Method::Generate::DemolishAll; }
          Method::Generate::DemolishAll->new
        })->generate_method($class);
      }
    }
    $NO_BUILD{$class} and
      return bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class);
    $NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class};
    $NO_BUILD{$class}
      ? bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class)
      : do {
          my $proto = ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
          bless({ %$proto }, $class)->BUILDALL($proto);
        };
  }
  
  # Inlined into Method::Generate::Constructor::_generate_args() - keep in sync
  sub BUILDARGS {
      my $class = shift;
      if ( scalar @_ == 1 ) {
          unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
              die "Single parameters to new() must be a HASH ref"
                  ." data => ". $_[0] ."\n";
          }
          return { %{ $_[0] } };
      }
      elsif ( @_ % 2 ) {
          die "The new() method for $class expects a hash reference or a key/value list."
                  . " You passed an odd number of arguments\n";
      }
      else {
          return {@_};
      }
  }
  
  sub BUILDALL {
    my $self = shift;
    $self->${\(($BUILD_MAKER ||= do {
      { local $@; require Method::Generate::BuildAll; }
      Method::Generate::BuildAll->new
    })->generate_method(ref($self)))}(@_);
  }
  
  sub DEMOLISHALL {
    my $self = shift;
    $self->${\(($DEMOLISH_MAKER ||= do {
      { local $@; require Method::Generate::DemolishAll; }
      Method::Generate::DemolishAll->new
    })->generate_method(ref($self)))}(@_);
  }
  
  sub does {
    { local $@; require Role::Tiny; }
    { no warnings 'redefine'; *does = \&Role::Tiny::does_role }
    goto &Role::Tiny::does_role;
  }
  
  1;
MOO_OBJECT

$fatpacked{"Moo/Role.pm"} = <<'MOO_ROLE';
  package Moo::Role;
  
  use strictures 1;
  use Moo::_Utils;
  use base qw(Role::Tiny);
  
  BEGIN { *INFO = \%Role::Tiny::INFO }
  
  our %INFO;
  
  sub import {
    my $target = caller;
    strictures->import;
    return if $INFO{$target}; # already exported into this package
    # get symbol table reference
    my $stash = do { no strict 'refs'; \%{"${target}::"} };
    *{_getglob "${target}::has"} = sub {
      my ($name, %spec) = @_;
      ($INFO{$target}{accessor_maker} ||= do {
        { local $@; require Method::Generate::Accessor; }
        Method::Generate::Accessor->new
      })->generate_method($target, $name, \%spec);
      $INFO{$target}{attributes}{$name} = \%spec;
    };
    goto &Role::Tiny::import;
  }
  
  sub apply_role_to_package {
    my ($me, $to, $role) = @_;
    $me->SUPER::apply_role_to_package($to, $role);
    $me->_handle_constructor($to, $INFO{$role}{attributes});
  }
  
  sub create_class_with_roles {
    my ($me, $superclass, @roles) = @_;
  
    my $new_name = join(
      '__WITH__', $superclass, my $compose_name = join '__AND__', @roles
    );
  
    return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
  
    { local $@; require Sub::Quote; }
  
    $me->SUPER::create_class_with_roles($superclass, @roles);
  
    foreach my $role (@roles) {
      die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
    }
  
    $Moo::MAKERS{$new_name} = {};
  
    $me->_handle_constructor(
      $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }, $superclass
    );
  
    return $new_name;
  }
  
  sub _install_single_modifier {
    my ($me, @args) = @_;
    _install_modifier(@args);
  }
  
  sub _handle_constructor {
    my ($me, $to, $attr_info, $superclass) = @_;
    return unless $attr_info && keys %$attr_info;
    if ($INFO{$to}) {
      @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
    } else {
      # only fiddle with the constructor if the target is a Moo class
      if ($INC{"Moo.pm"}
          and my $con = Moo->_constructor_maker_for($to, $superclass)) {
        $con->register_attribute_specs(%$attr_info);
      }
    }
  }
  
  1;
  
  =head1 NAME
  
  Moo::Role - Minimal Object Orientation support for Roles
  
  =head1 SYNOPSIS
  
   package My::Role;
  
   use Moo::Role;
  
   sub foo { ... }
  
   sub bar { ... }
  
   has baz => (
     is => 'ro',
   );
  
   1;
  
  else where
  
   package Some::Class;
  
   use Moo;
  
   # bar gets imported, but not foo
   with('My::Role');
  
   sub foo { ... }
  
   1;
  
  =head1 DESCRIPTION
  
  C<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
  documentation on how this works.  The main addition here is extra bits to make
  the roles more "Moosey;" which is to say, it adds L</has>.
  
  =head1 IMPORTED SUBROUTINES
  
  See L<Role::Tiny/IMPORTED SUBROUTINES> for all the other subroutines that are
  imported by this module.
  
  =head2 has
  
   has attr => (
     is => 'ro',
   );
  
  Declares an attribute for the class to be composed into.  See
  L<Moo/has> for all options.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
  
  =cut
MOO_ROLE

$fatpacked{"Moo/_Utils.pm"} = <<'MOO__UTILS';
  package Moo::_Utils;
  
  sub _getglob { \*{$_[0]} }
  sub _getstash { \%{"$_[0]::"} }
  
  BEGIN {
    *lt_5_8_3 = $] < 5.008003
      ? sub () { 1 }
      : sub () { 0 }
    ;
  }
  
  use strictures 1;
  use base qw(Exporter);
  use Moo::_mro;
  
  our @EXPORT = qw(
      _getglob _install_modifier _load_module _maybe_load_module
      _get_linear_isa
  );
  
  sub _install_modifier {
    my ($into, $type, $name, $code) = @_;
  
    if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
      { local $@; require Sub::Defer; }
      Sub::Defer::undefer_sub($to_modify);
    }
  
    Class::Method::Modifiers::install_modifier(@_);
  }
  
  our %MAYBE_LOADED;
  
  # _load_module is inlined in Role::Tiny - make sure to copy if you update it.
  
  sub _load_module {
    (my $proto = $_[0]) =~ s/::/\//g;
    return 1 if $INC{"${proto}.pm"};
    # can't just ->can('can') because a sub-package Foo::Bar::Baz
    # creates a 'Baz::' key in Foo::Bar's symbol table
    return 1 if grep !/::$/, keys %{_getstash($_[0])||{}};
    { local $@; require "${proto}.pm"; }
    return 1;
  }
  
  sub _maybe_load_module {
    return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
    (my $proto = $_[0]) =~ s/::/\//g;
    local $@;
    if (eval { require "${proto}.pm"; 1 }) {
      $MAYBE_LOADED{$_[0]} = 1;
    } else {
      if (exists $INC{"${proto}.pm"}) {
        warn "$_[0] exists but failed to load with error: $@";
      }
      $MAYBE_LOADED{$_[0]} = 0;
    }
    return $MAYBE_LOADED{$_[0]};
  }
  
  sub _get_linear_isa {
      return mro::get_linear_isa($_[0]);
  }
  
  our $_in_global_destruction = 0;
  END { $_in_global_destruction = 1 }
  
  sub STANDARD_DESTROY {
    my $self = shift;
  
    my $e = do {
      local $?;
      local $@;
      eval {
        $self->DEMOLISHALL($_in_global_destruction);
      };
      $@;
    };
  
    no warnings 'misc';
    die $e if $e; # rethrow
  }
  
  1;
MOO__UTILS

$fatpacked{"Moo/_mro.pm"} = <<'MOO__MRO';
  package Moo::_mro;
  
  local $@;
  
  if ($] >= 5.010) {
    require mro;
  } else {
    require MRO::Compat;
  }
  
  1;
MOO__MRO

$fatpacked{"Role/Tiny.pm"} = <<'ROLE_TINY';
  package Role::Tiny;
  
  sub _getglob { \*{$_[0]} }
  sub _getstash { \%{"$_[0]::"} }
  
  use strict;
  use warnings FATAL => 'all';
  
  our %INFO;
  our %APPLIED_TO;
  our %COMPOSED;
  
  # inlined from Moo::_Utils - update that first.
  
  sub _load_module {
    (my $proto = $_[0]) =~ s/::/\//g;
    return 1 if $INC{"${proto}.pm"};
    # can't just ->can('can') because a sub-package Foo::Bar::Baz
    # creates a 'Baz::' key in Foo::Bar's symbol table
    return 1 if grep !/::$/, keys %{_getstash($_[0])||{}};
    { local $@; require "${proto}.pm"; }
    return 1;
  }
  
  { # \[] is REF, not SCALAR. \v1 is VSTRING (thanks to doy for that one)
    my %reftypes = map +($_ => 1), qw(SCALAR REF VSTRING);
    sub _is_scalar_ref { $reftypes{ref($_[0])} }
  }
  
  sub import {
    my $target = caller;
    my $me = shift;
    strictures->import;
    return if $INFO{$target}; # already exported into this package
    # get symbol table reference
    my $stash = do { no strict 'refs'; \%{"${target}::"} };
    # install before/after/around subs
    foreach my $type (qw(before after around)) {
      *{_getglob "${target}::${type}"} = sub {
        { local $@; require Class::Method::Modifiers; }
        push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
      };
    }
    *{_getglob "${target}::requires"} = sub {
      push @{$INFO{$target}{requires}||=[]}, @_;
    };
    *{_getglob "${target}::with"} = sub {
      die "Only one role supported at a time by with" if @_ > 1;
      $me->apply_role_to_package($target, $_[0]);
    };
    # grab all *non-constant* (stash slot is not a scalarref) subs present
    # in the symbol table and store their refaddrs (no need to forcibly
    # inflate constant subs into real subs) - also add '' to here (this
    # is used later)
    @{$INFO{$target}{not_methods}={}}{
      '', map { *$_{CODE}||() } grep !_is_scalar_ref($_), values %$stash
    } = ();
    # a role does itself
    $APPLIED_TO{$target} = { $target => undef };
  }
  
  sub apply_role_to_package {
    my ($me, $to, $role) = @_;
  
    _load_module($role);
  
    die "This is apply_role_to_package" if ref($to);
    die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
  
    $me->_check_requires($to, $role, @{$info->{requires}||[]});
  
    $me->_install_methods($to, $role);
  
    $me->_install_modifiers($to, $info->{modifiers});
  
    # only add does() method to classes and only if they don't have one
    if (not $INFO{$to} and not $to->can('does')) {
      *{_getglob "${to}::does"} = \&does_role;
    }
  
    # copy our role list into the target's
    @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
  }
  
  sub apply_roles_to_object {
    my ($me, $object, @roles) = @_;
    die "No roles supplied!" unless @roles;
    my $class = ref($object);
    bless($object, $me->create_class_with_roles($class, @roles));
    $object;
  }
  
  sub create_class_with_roles {
    my ($me, $superclass, @roles) = @_;
  
    die "No roles supplied!" unless @roles;
  
    my $new_name = join(
      '__WITH__', $superclass, my $compose_name = join '__AND__', @roles
    );
  
    return $new_name if $COMPOSED{class}{$new_name};
  
    foreach my $role (@roles) {
      _load_module($role);
      die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
    }
  
    if ($] >= 5.010) {
      { local $@; require mro; }
    } else {
      { local $@; require MRO::Compat; }
    }
  
    my @composable = map $me->_composable_package_for($_), reverse @roles;
  
    *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ];
  
    my @info = map +($INFO{$_} ? $INFO{$_} : ()), @roles;
  
    $me->_check_requires(
      $new_name, $compose_name,
      do { my %h; @h{map @{$_->{requires}||[]}, @info} = (); keys %h }
    );
  
    *{_getglob "${new_name}::does"} = \&does_role unless $new_name->can('does');
  
    @{$APPLIED_TO{$new_name}||={}}{
      map keys %{$APPLIED_TO{$_}}, @roles
    } = ();
  
    $COMPOSED{class}{$new_name} = 1;
    return $new_name;
  }
  
  sub _composable_package_for {
    my ($me, $role) = @_;
    my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
    return $composed_name if $COMPOSED{role}{$composed_name};
    $me->_install_methods($composed_name, $role);
    my $base_name = $composed_name.'::_BASE';
    *{_getglob("${composed_name}::ISA")} = [ $base_name ];
    my $modifiers = $INFO{$role}{modifiers}||[];
    my @mod_base;
    foreach my $modified (
      do { my %h; @h{map $_->[1], @$modifiers} = (); keys %h }
    ) {
      push @mod_base, "sub ${modified} { shift->next::method(\@_) }";
    }
    {
      local $@;
      eval(my $code = join "\n", "package ${base_name};", @mod_base);
      die "Evaling failed: $@\nTrying to eval:\n${code}" if $@;
    }
    $me->_install_modifiers($composed_name, $modifiers);
    $COMPOSED{role}{$composed_name} = 1;
    return $composed_name;
  }
  
  sub _check_requires {
    my ($me, $to, $name, @requires) = @_;
    if (my @requires_fail = grep !$to->can($_), @requires) {
      # role -> role, add to requires, role -> class, error out
      if (my $to_info = $INFO{$to}) {
        push @{$to_info->{requires}||=[]}, @requires_fail;
      } else {
        die "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail);
      }
    }
  }
  
  sub _concrete_methods_of {
    my ($me, $role) = @_;
    my $info = $INFO{$role};
    $info->{methods} ||= do {
      # grab role symbol table
      my $stash = do { no strict 'refs'; \%{"${role}::"}};
      my $not_methods = $info->{not_methods};
      +{
        # grab all code entries that aren't in the not_methods list
        map {
          my $code = *{$stash->{$_}}{CODE};
          # rely on the '' key we added in import for "no code here"
          exists $not_methods->{$code||''} ? () : ($_ => $code)
        } grep !_is_scalar_ref($stash->{$_}), keys %$stash
      };
    };
  }
  
  sub methods_provided_by {
    my ($me, $role) = @_;
    die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
    (keys %{$me->_concrete_methods_of($role)}, @{$info->{requires}||[]});
  }
  
  sub _install_methods {
    my ($me, $to, $role) = @_;
  
    my $info = $INFO{$role};
  
    my $methods = $me->_concrete_methods_of($role);
  
    # grab target symbol table
    my $stash = do { no strict 'refs'; \%{"${to}::"}};
  
    # determine already extant methods of target
    my %has_methods;
    @has_methods{grep
      +(_is_scalar_ref($stash->{$_}) || *{$stash->{$_}}{CODE}),
      keys %$stash
    } = ();
  
    foreach my $i (grep !exists $has_methods{$_}, keys %$methods) {
      no warnings 'once';
      *{_getglob "${to}::${i}"} = $methods->{$i};
    }
  }
  
  sub _install_modifiers {
    my ($me, $to, $modifiers) = @_;
    if (my $info = $INFO{$to}) {
      push @{$info->{modifiers}}, @{$modifiers||[]};
    } else {
      foreach my $modifier (@{$modifiers||[]}) {
        $me->_install_single_modifier($to, @$modifier);
      }
    }
  }
  
  sub _install_single_modifier {
    my ($me, @args) = @_;
    Class::Method::Modifiers::install_modifier(@args);
  }
  
  sub does_role {
    my ($proto, $role) = @_;
    return exists $APPLIED_TO{ref($proto)||$proto}{$role};
  }
  
  1;
  
  =head1 NAME
  
  Role::Tiny - Roles. Like a nouvelle cusine portion size slice of Moose.
  
  =head1 SYNOPSIS
  
   package Some::Role;
  
   use Role::Tiny;
  
   sub foo { ... }
  
   sub bar { ... }
  
   1;
  
  else where
  
   package Some::Class;
  
   use Role::Tiny::With;
  
   # bar gets imported, but not foo
   with 'Some::Role';
  
   sub foo { ... }
  
   1;
  
  =head1 DESCRIPTION
  
  C<Role::Tiny> is a minimalist role composition tool.
  
  =head1 ROLE COMPOSITION
  
  Role composition can be thought of as much more clever and meaningful multiple
  inheritance.  The basics of this implementation of roles is:
  
  =over 2
  
  =item *
  
  If a method is already defined on a class, that method will not be composed in
  from the role.
  
  =item *
  
  If a method that the role L</requires> to be implemented is not implemented,
  role application will fail loudly.
  
  =back
  
  Unlike L<Class::C3>, where the B<last> class inherited from "wins," role
  composition is the other way around, where first wins.  In a more complete
  system (see L<Moose>) roles are checked to see if they clash.  The goal of this
  is to be much simpler, hence disallowing composition of multiple roles at once.
  
  =head1 METHODS
  
  =head2 apply_role_to_package
  
   Role::Tiny->apply_role_to_package('Some::Package', 'Some::Role');
  
  Composes role with package.  See also L<Role::Tiny::With>.
  
  =head2 apply_roles_to_object
  
   Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2));
  
  Composes roles in order into object directly.  Object is reblessed into the
  resulting class.
  
  =head2 create_class_with_roles
  
   Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2));
  
  Creates a new class based on base, with the roles composed into it in order.
  New class is returned.
  
  =head1 SUBROUTINES
  
  =head2 does_role
  
   if (Role::Tiny::does_role($foo, 'Some::Role')) {
     ...
   }
  
  Returns true if class has been composed with role.
  
  This subroutine is also installed as ->does on any class a Role::Tiny is
  composed into unless that class already has an ->does method, so
  
    if ($foo->does_role('Some::Role')) {
      ...
    }
  
  will work for classes but to test a role, one must use ::does_role directly
  
  =head1 IMPORTED SUBROUTINES
  
  =head2 requires
  
   requires qw(foo bar);
  
  Declares a list of methods that must be defined to compose role.
  
  =head2 with
  
   with 'Some::Role1';
   with 'Some::Role2';
  
  Composes another role into the current role.  Only one role may be composed in
  at a time to allow the code to remain as simple as possible.
  
  =head2 before
  
   before foo => sub { ... };
  
  See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full
  documentation.
  
  =head2 around
  
   around foo => sub { ... };
  
  See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full
  documentation.
  
  =head2 after
  
   after foo => sub { ... };
  
  See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full
  documentation.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
  
  =cut
ROLE_TINY

$fatpacked{"Role/Tiny/With.pm"} = <<'ROLE_TINY_WITH';
  package Role::Tiny::With;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Exporter 'import';
  our @EXPORT = qw( with );
  
  sub with {
      my $target = caller;
      Role::Tiny->apply_role_to_package($target, @_)
  }
  
  1;
  
  =head1 NAME
  
  Role::Tiny::With - Neat interface for consumers of Role::Tiny roles
  
  =head1 SYNOPSIS
  
   package Some::Class;
  
   use Role::Tiny::With;
  
   with 'Some::Role';
  
   # The role is now mixed in
  
  =head1 DESCRIPTION
  
  C<Role::Tiny> is a minimalist role composition tool.  C<Role::Tiny::With>
  provides a C<with> function to compose such roles.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
  
  =cut
  
  
ROLE_TINY_WITH

$fatpacked{"Sub/Defer.pm"} = <<'SUB_DEFER';
  package Sub::Defer;
  
  use strictures 1;
  use base qw(Exporter);
  use Moo::_Utils;
  
  our @EXPORT = qw(defer_sub undefer_sub);
  
  our %DEFERRED;
  
  sub undefer_sub {
    my ($deferred) = @_;
    my ($target, $maker, $undeferred_ref) = @{
      $DEFERRED{$deferred}||return $deferred
    };
    ${$undeferred_ref} = my $made = $maker->();
  
    # make sure the method slot has not changed since deferral time
    if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
      no warnings 'redefine';
      *{_getglob($target)} = $made;
    }
    push @{$DEFERRED{$made} = $DEFERRED{$deferred}}, $made;
  
    return $made;
  }
  
  sub defer_info {
    my ($deferred) = @_;
    $DEFERRED{$deferred||''};
  }
  
  sub defer_sub {
    my ($target, $maker) = @_;
    my $undeferred;
    my $deferred_string;
    my $deferred = sub {
      goto &{$undeferred ||= undefer_sub($deferred_string)};
    };
    $deferred_string = "$deferred";
    $DEFERRED{$deferred} = [ $target, $maker, \$undeferred ];
    *{_getglob $target} = $deferred if defined($target);
    return $deferred;
  }
  
  1;
  
  =head1 NAME
  
  Sub::Defer - defer generation of subroutines until they are first called
  
  =head1 SYNOPSIS
  
   use Sub::Defer;
  
   my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
      my $t = time;
      sub { time - $t };
   };
  
    Logger->time_since_first_log; # returns 0 and replaces itself
    Logger->time_since_first_log; # returns time - $t
  
  =head1 DESCRIPTION
  
  These subroutines provide the user with a convenient way to defer creation of
  subroutines and methods until they are first called.
  
  =head1 SUBROUTINES
  
  =head2 defer_sub
  
   my $coderef = defer_sub $name => sub { ... };
  
  This subroutine returns a coderef that encapsulates the provided sub - when
  it is first called, the provided sub is called and is -itself- expected to
  return a subroutine which will be goto'ed to on subsequent calls.
  
  If a name is provided, this also installs the sub as that name - and when
  the subroutine is undeferred will re-install the final version for speed.
  
  =head2 undefer_sub
  
   my $coderef = undefer_sub \&Foo::name;
  
  If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
  If the passed coderef has not been deferred, this will just return it.
  
  If this is confusing, take a look at the example in the L</SYNOPSIS>.
SUB_DEFER

$fatpacked{"Sub/Quote.pm"} = <<'SUB_QUOTE';
  package Sub::Quote;
  
  use strictures 1;
  
  sub _clean_eval { eval $_[0] }
  
  use Sub::Defer;
  use B 'perlstring';
  use Scalar::Util qw(weaken);
  use base qw(Exporter);
  
  our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub);
  
  our %QUOTE_OUTSTANDING;
  
  our %QUOTED;
  
  our %WEAK_REFS;
  
  sub capture_unroll {
    my ($from, $captures, $indent) = @_;
    join(
      '',
      map {
        /^([\@\%\$])/
          or die "capture key should start with \@, \% or \$: $_";
        (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
      } keys %$captures
    );
  }
  
  sub inlinify {
    my ($code, $args, $extra, $local) = @_;
    my $do = 'do { '.($extra||'');
    if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) {
      if ($code_args eq $args) {
        $do.$body.' }'
      } else {
        $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }';
      }
    } else {
      $do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }';
    }
  }
  
  sub _unquote_all_outstanding {
    return unless %QUOTE_OUTSTANDING;
    my ($assembled_code, @assembled_captures, @localize_these) = '';
    # we sort the keys in order to make debugging more predictable
    foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) {
      my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}};
  
      push @localize_these, $name if $name;
  
      my $make_sub = "{\n";
  
      if (keys %$captures) {
        my $ass_cap_count = @assembled_captures;
        $make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2);
        push @assembled_captures, $captures;
      }
  
      my $o_quoted = perlstring $outstanding;
      $make_sub .= (
        $name
            # disable the 'variable $x will not stay shared' warning since
            # we're not letting it escape from this scope anyway so there's
            # nothing trying to share it
          ? "  no warnings 'closure';\n  sub ${name} {\n"
          : "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n"
      );
      $make_sub .= $code;
      $make_sub .= "  }".($name ? '' : ';')."\n";
      if ($name) {
        $make_sub .= "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n";
      }
      $make_sub .= "}\n";
      $assembled_code .= $make_sub;
    }
    my $debug_code = $assembled_code;
    if (@localize_these) {
      $debug_code =
        "# localizing: ".join(', ', @localize_these)."\n"
        .$assembled_code;
      $assembled_code = join("\n",
        (map { "local *${_};" } @localize_these),
        'eval '.perlstring($assembled_code).'; die $@ if $@;'
      );
    } else {
      $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
    }
    $assembled_code .= "\n1;";
    {
      local $@;
      unless (_clean_eval $assembled_code, \@assembled_captures) {
        die "Eval went very, very wrong:\n\n${debug_code}\n\n$@";
      }
    }
    $ENV{SUB_QUOTE_DEBUG} && warn $debug_code;
    %QUOTE_OUTSTANDING = ();
  }
  
  sub quote_sub {
    # HOLY DWIMMERY, BATMAN!
    # $name => $code => \%captures => \%options
    # $name => $code => \%captures
    # $name => $code
    # $code => \%captures => \%options
    # $code
    my $options =
      (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
        ? pop
        : {};
    my $captures = pop if ref($_[-1]) eq 'HASH';
    undef($captures) if $captures && !keys %$captures;
    my $code = pop;
    my $name = $_[0];
    my $outstanding;
    my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
      unquote_sub($outstanding);
    };
    $outstanding = "$deferred";
    $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [
      $name, $code, $captures
    ];
    weaken($WEAK_REFS{$outstanding} = $deferred);
    return $deferred;
  }
  
  sub quoted_from_sub {
    my ($sub) = @_;
    $WEAK_REFS{$sub||''} and $QUOTED{$sub||''};
  }
  
  sub unquote_sub {
    my ($sub) = @_;
    _unquote_all_outstanding;
    $QUOTED{$sub}[3];
  }
  
  1;
  
  =head1 NAME
  
  Sub::Quote - efficient generation of subroutines via string eval
  
  =head1 SYNOPSIS
  
   package Silly;
  
   use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
  
   quote_sub 'Silly::kitty', q{ print "meow" };
  
   quote_sub 'Silly::doggy', q{ print "woof" };
  
   my $sound; $$sound = 0;
  
   quote_sub 'Silly::dagron',
     q{ print ++$$sound % 2 ? 'burninate' : 'roar' },
     { '$sound' => \$sound };
  
  And elsewhere:
  
   Silly->kitty;  # meow
   Silly->doggy;  # woof
   Silly->dagron; # burninate
   Silly->dagron; # roar
   Silly->dagron; # burninate
  
  =head1 DESCRIPTION
  
  This package provides performant ways to generate subroutines from strings.
  
  =head1 SUBROUTINES
  
  =head2 quote_sub
  
   my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
  
  Arguments: ?$name, $code, ?\%captures, ?\%options
  
  C<$name> is the subroutine where the coderef will be installed.
  
  C<$code> is a string that will be turned into code.
  
  C<\%captures> is a hashref of variables that will be made available to the
  code.  See the L</SYNOPSIS>'s C<Silly::dagron> for an example using captures.
  
  =head3 options
  
  =over 2
  
  =item * no_install
  
  B<Boolean>.  Set this option to not install the generated coderef into the
  passed subroutine name on undefer.
  
  =back
  
  =head2 unquote_sub
  
   my $coderef = unquote_sub $sub;
  
  Forcibly replace subroutine with actual code.  Note that for performance
  reasons all quoted subs declared so far will be globally unquoted/parsed in
  a single eval. This means that if you have a syntax error in one of your
  quoted subs you may find out when some other sub is unquoted.
  
  If $sub is not a quoted sub, this is a no-op.
  
  =head2 quoted_from_sub
  
   my $data = quoted_from_sub $sub;
  
   my ($name, $code, $captures, $compiled_sub) = @$data;
  
  Returns original arguments to quote_sub, plus the compiled version if this
  sub has already been unquoted.
  
  Note that $sub can be either the original quoted version or the compiled
  version for convenience.
  
  =head2 inlinify
  
   my $prelude = capture_unroll {
     '$x' => 1,
     '$y' => 2,
   };
  
   my $inlined_code = inlinify q{
     my ($x, $y) = @_;
  
     print $x + $y . "\n";
   }, '$x, $y', $prelude;
  
  Takes a string of code, a string of arguments, a string of code which acts as a
  "prelude", and a B<Boolean> representing whether or not to localize the
  arguments.
  
  =head2 capture_unroll
  
   my $prelude = capture_unroll {
     '$x' => 1,
     '$y' => 2,
   };
  
  Generates a snippet of code which is suitable to be used as a prelude for
  L</inlinify>.  The keys are the names of the variables and the values are (duh)
  the values.  Note that references work as values.
SUB_QUOTE

$fatpacked{"Tak.pm"} = <<'TAK';
  package Tak;
  
  use Tak::Loop;
  use strictures 1;
  
  our $VERSION = '0.001003'; # 0.1.3
  
  our ($loop, $did_upgrade);
  
  sub loop { $loop ||= Tak::Loop->new }
  
  sub loop_upgrade {
    return if $did_upgrade;
    require IO::Async::Loop;
    my $new_loop = IO::Async::Loop->new;
    $loop->pass_watches_to($new_loop) if $loop;
    $loop = $new_loop;
    $did_upgrade = 1;
  }
  
  sub loop_until {
    my ($class, $done) = @_;
    return if $done;
    $class->loop->loop_once until $_[1];
  }
  
  sub await_all {
    my ($class, @requests) = @_;
    @requests = grep !$_->is_done, @requests;
    return unless @requests;
    my %req = map +("$_" => "$_"), @requests;
    my $done;
    my %on_r = map {
      my $orig = $_->{on_result};
      my $tag = $req{$_};
      ($_ => sub { delete $req{$tag}; $orig->(@_); $done = 1 unless keys %req; })
    } @requests;
    my $call = sub { $class->loop_until($done) };
    foreach (@requests) {
      my $req = $_;
      my $inner = $call;
      $call = sub { local $req->{on_result} = $on_r{$req}; $inner->() };
    }
    $call->();
    return;
  }
  
  1;
  
  =head1 NAME
  
  Tak - Multi host remote control over ssh
  
  =head1 SYNOPSIS
  
    bin/tak -h user1@host1 -h user2@host2 exec cat /etc/hostname
  
  or
  
    in Takfile:
  
    package Tak::MyScript;
    
    use Tak::Takfile;
    use Tak::ObjectClient;
    
    sub each_get_homedir {
      my ($self, $remote) = @_;
      my $oc = Tak::ObjectClient->new(remote => $remote);
      my $home = $oc->new_object('Path::Class::Dir')->absolute->stringify;
      $self->stdout->print(
        $remote->host.': '.$home."\n"
      );
    }
    
    1;
  
  then
  
    tak -h something get-homedir
  
  =head1 WHERE'S THE REST?
  
  A drink leaked in my bag on the way back from LPW. You'll get more once I
  get my laptop's drive into an enclosure and decant the slides.
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  None required yet. Maybe this module is perfect (hahahahaha ...).
  
  =head1 COPYRIGHT
  
  Copyright (c) 2011 the strictures L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
TAK

$fatpacked{"Tak/Client.pm"} = <<'TAK_CLIENT';
  package Tak::Client;
  
  use Tak;
  use Tak::Request;
  use Moo;
  
  has service => (is => 'ro', required => 1);
  
  has curried => (is => 'ro', default => sub { [] });
  
  sub curry {
    my ($self, @curry) = @_;
    (ref $self)->new(%$self, curried => [ @{$self->curried}, @curry ]);
  }
  
  sub send { shift->receive(@_) }
  
  sub receive {
    my ($self, @message) = @_;
    $self->service->receive(@{$self->curried}, @message);
  }
  
  sub start {
    my ($self, $register, @payload) = @_;
    my $req = $self->_new_request($register);
    $self->start_request($req, @payload);
    return $req;
  }
  
  sub start_request {
    my ($self, $req, @payload) = @_;
    $self->service->start_request($req, @{$self->curried}, @payload);
  }
  
  sub request_class { 'Tak::Request' }
  
  sub _new_request {
    my ($self, $args) = @_;
    $self->request_class->new($args);
  }
  
  sub do {
    shift->result_of(@_)->get;
  }
  
  sub result_of {
    my ($self, @payload) = @_;
    my $done;
    my $result;
    my $req = $self->start({
      on_result => sub { $result = shift },
    }, @payload);
    Tak->loop_until($result);
    return $result;
  }
  
  sub clone_or_self {
    my ($self) = @_;
    (ref $self)->new(
      service => $self->service->clone_or_self, 
      curried => [ @{$self->curried} ],
    );
  }
  
  1;
TAK_CLIENT

$fatpacked{"Tak/Client/RemoteRouter.pm"} = <<'TAK_CLIENT_REMOTEROUTER';
  package Tak::Client::RemoteRouter;
  
  use Moo;
  
  extends 'Tak::Client::Router';
  
  has host => (is => 'ro', required => 1);
  
  1;
TAK_CLIENT_REMOTEROUTER

$fatpacked{"Tak/Client/Router.pm"} = <<'TAK_CLIENT_ROUTER';
  package Tak::Client::Router;
  
  use Moo;
  
  extends 'Tak::Client';
  
  sub ensure {
    shift->do(meta => ensure => @_);
  }
  
  1;
TAK_CLIENT_ROUTER

$fatpacked{"Tak/CommandService.pm"} = <<'TAK_COMMANDSERVICE';
  package Tak::CommandService;
  
  use Capture::Tiny qw(capture);
  use IPC::System::Simple qw(runx EXIT_ANY);
  use IPC::Open3;
  use Symbol qw(gensym);
  use Moo;
  
  with 'Tak::Role::Service';
  
  sub handle_exec {
    my ($self, $command) = @_;
    my $code;
    my ($stdout, $stderr) = capture {
      $code = runx(EXIT_ANY, @$command);
    };
    return { stdout => $stdout, stderr => $stderr, exit_code => $code };
  }
  
  sub start_stream_exec_request {
    my ($self, $req, $command) = @_;
    my $err = gensym;
    my $pid = open3(my $in, my $out, $err, @$command)
      or return $req->failure("Couldn't spawn process: $!");
    close($in); # bye
    my $done = sub {
      Tak->loop->unwatch_io(handle => $_, on_read_ready => 1)
        for ($out, $err);
      waitpid($pid, 0);
      $req->success({ exit_code => $? });
    };
    my $outbuf = '';
    my $errbuf = '';
    Tak->loop->watch_io(
      handle => $out,
      on_read_ready => sub {
        if (sysread($out, $outbuf, 1024, length($outbuf)) > 0) {
          $req->progress(stdout => $1) while $outbuf =~ s/^(.*)\n//;
        } else {
          $req->progress(stdout => $outbuf) if $outbuf;
          $req->progress(stderr => $errbuf) if $errbuf;
          $done->();
        }
      }
    );
    Tak->loop->watch_io(
      handle => $err,
      on_read_ready => sub {
        if (sysread($err, $errbuf, 1024, length($errbuf)) > 0) {
          $req->progress(stderr => $1) while $errbuf =~ s/^(.*)\n//;
        }
      }
    );
  }
  
  1;
TAK_COMMANDSERVICE

$fatpacked{"Tak/ConnectionReceiver.pm"} = <<'TAK_CONNECTIONRECEIVER';
  package Tak::ConnectionReceiver;
  
  use Tak::Request;
  use Scalar::Util qw(weaken);
  use Log::Contextual qw(:log);
  use Moo;
  
  with 'Tak::Role::Service';
  
  has requests => (is => 'ro', default => sub { {} });
  
  has channel => (is => 'ro', required => 1);
  
  has service => (is => 'ro', required => 1);
  
  has on_close => (is => 'ro', required => 1);
  
  sub BUILD {
    weaken(my $self = shift);
    my $channel = $self->channel;
    Tak->loop->watch_io(
      handle => $channel->read_fh,
      on_read_ready => sub {
        $channel->read_messages(sub { $self->receive(@_) });
      }
    );
  }
  
  sub DEMOLISH {
    Tak->loop->unwatch_io(
      handle => $_[0]->channel->read_fh,
      on_read_ready => 1,
    );
  }
  
  sub receive_request {
    my ($self, $tag, $meta, @payload) = @_;
    my $channel = $self->channel;
    unless (ref($meta) eq 'HASH') {
      $channel->write_message(mistake => $tag => 'meta value not a hashref');
      return;
    }
    my $req = Tak::Request->new(
      ($meta->{progress}
          ? (on_progress => sub { $channel->write_message(progress => $tag => @_) })
          : ()),
      on_result => sub { $channel->write_message(result => $tag => $_[0]->flatten) }
    );
    $self->service->start_request($req => @payload);
  }
  
  sub receive_progress {
    my ($self, $tag, @payload) = @_;
    $self->requests->{$tag}->progress(@payload);
  }
  
  sub receive_result {
    my ($self, $tag, @payload) = @_;
    (delete $self->requests->{$tag})->result(@payload);
  }
  
  sub receive_message {
    my ($self, @payload) = @_;
    $self->service->receive(@payload);
  }
  
  sub receive_close {
    my ($self, @payload) = @_;
    $self->on_close->(@payload);
  }
  
  1;
TAK_CONNECTIONRECEIVER

$fatpacked{"Tak/ConnectionService.pm"} = <<'TAK_CONNECTIONSERVICE';
  package Tak::ConnectionService;
  
  use Tak::ConnectionReceiver;
  use Tak::JSONChannel;
  use Moo;
  
  has receiver => (is => 'ro', writer => '_set_receiver');
  
  has channel => (is => 'ro', writer => '_set_channel');
  
  sub BUILD {
    my ($self, $args) = @_;
    my $channel = $self->_set_channel(
      Tak::JSONChannel->new(map +($_ => $args->{$_}), qw(read_fh write_fh))
    );
    my $receiver = $self->_set_receiver(
      Tak::ConnectionReceiver->new(
        channel => $channel, service => $args->{listening_service},
        on_close => $args->{on_close},
      )
    );
  }
  
  sub start_request {
    my ($self, $req, @payload) = @_;
    $self->receiver->requests->{my $tag = "$req"} = $req;
    my $meta = { progress => !!$req->on_progress };
    $self->channel->write_message(request => $tag => $meta => @payload);
  }
  
  sub receive {
    my ($self, @payload) = @_;
    $self->channel->write_message(message => @payload);
  }
  
  1;
TAK_CONNECTIONSERVICE

$fatpacked{"Tak/ConnectorService.pm"} = <<'TAK_CONNECTORSERVICE';
  package Tak::ConnectorService;
  
  use IPC::Open2;
  use IO::Socket::UNIX;
  use IO::Socket::INET; # Sucks to be v6, see comment where used
  use IO::All;
  use Tak::Router;
  use Tak::Client;
  use Tak::ConnectionService;
  use Net::OpenSSH;
  use Tak::STDIONode;
  use Moo;
  
  with 'Tak::Role::Service';
  
  has connections => (is => 'ro', default => sub { Tak::Router->new });
  
  has ssh => (is => 'ro', default => sub { {} });
  
  sub handle_create {
    my ($self, $on, %args) = @_;
    die [ mistake => "No target supplied to create" ] unless $on;
    my $log_level = $args{log_level}||'info';
    my ($kid_in, $kid_out, $kid_pid) = $self->_open($on, $log_level);
    if ($kid_pid) {
      $kid_in->print($Tak::STDIONode::DATA, "__END__\n") unless $on eq '-';
      # Need to get a handshake to indicate STDIOSetup has finished
      # messing around with file descriptors, otherwise we can severely
      # confuse things by sending before the dup.
      my $up = <$kid_out>;
      die [ failure => "Garbled response from child: $up" ]
        unless $up eq "Ssyshere\n";
    }
    my $connection = Tak::ConnectionService->new(
      read_fh => $kid_out, write_fh => $kid_in,
      listening_service => Tak::Router->new
    );
    my $client = Tak::Client->new(service => $connection);
    # actually, we should register with a monotonic id and
    # stash the pid elsewhere. but meh for now.
    my $pid = $client->do(meta => 'pid');
    my $name = $on.':'.$pid;
    my $conn_router = Tak::Router->new;
    $conn_router->register(local => $connection->receiver->service);
    $conn_router->register(remote => $connection);
    $self->connections->register($name, $conn_router);
    return ($name);
  }
  
  sub _open {
    my ($self, $on, @args) = @_;
    if ($on eq '-') {
      my $kid_pid = IPC::Open2::open2(my $kid_out, my $kid_in, 'tak-stdio-node', '-', @args)
        or die "Couldn't open2 child: $!";
      return ($kid_in, $kid_out, $kid_pid);
    } elsif ($on =~ /^\.?\//) { # ./foo or /foo
      my $sock = IO::Socket::UNIX->new($on)
        or die "Couldn't open unix domain socket ${on}: $!";
      return ($sock, $sock, undef);
    } elsif ($on =~ /:/) { # foo:80 we hope
      # IO::Socket::IP is a better answer. But can pull in XS deps.
      # Well, more strictly it pulls in Socket::GetAddrInfo, which can
      # actually work without its XS implementation (just doesn't handle v6)
      # and I've not properly pondered how to make things like fatpacking
      # Just Fucking Work in such a circumstance. First person to need IPv6
      # and be reading this comment, please start a conversation about it.
      my $sock = IO::Socket::INET->new(PeerAddr => $on)
        or die "Couldn't open TCP socket ${on}: $!";
      return ($sock, $sock, undef);
    }
    my $ssh = $self->ssh->{$on} ||= Net::OpenSSH->new($on);
    $ssh->error and
      die "Couldn't establish ssh connection: ".$ssh->error;
    return $ssh->open2('perl','-', $on, @args);
  }
  
  sub start_connection_request {
    my ($self, $req, @payload) = @_;;
    $self->connections->start_request($req, @payload);
  }
  
  sub receive_connection {
    my ($self, @payload) = @_;
    $self->connections->receive(@payload);
  }
  
  1;
TAK_CONNECTORSERVICE

$fatpacked{"Tak/EvalService.pm"} = <<'TAK_EVALSERVICE';
  package Tak::EvalService;
  
  use Eval::WithLexicals;
  use Data::Dumper::Concise;
  use Capture::Tiny qw(capture);
  use Moo;
  
  with 'Tak::Role::Service';
  
  has 'eval_withlexicals' => (is => 'lazy');
  
  has 'service_client' => (is => 'ro', predicate => 'has_service_client');
  
  sub _build_eval_withlexicals {
    my ($self) = @_;
    Eval::WithLexicals->new(
      $self->has_service_client
        ? (lexicals => { '$client' => \($self->service_client) })
        : ()
    );
  }
  
  sub handle_eval {
    my ($self, $perl) = @_;
    unless ($perl) {
      die [ mistake => eval_input => "No code supplied" ];
    }
    if (my $ref = ref($perl)) {
      die [ mistake => eval_input => "Code was a ${ref} reference" ];
    }
    my ($ok, @ret);
    my ($stdout, $stderr);
    if (eval {
      ($stdout, $stderr) = capture {
        @ret = $self->eval_withlexicals->eval($perl);
      };
      1
    }) {
      $ok = 1;
    } else {
      ($ok, @ret) = (0, $@);
    }
    my $dumped_ret;
    unless (eval { $dumped_ret = Dumper(@ret); 1 }) {
      $dumped_ret = "Error dumping ${\($ok ? 'result' : 'exception')}: $@";
      $ok = 0;
    }
    return {
      stdout => $stdout, stderr => $stderr,
      ($ok ? 'return' : 'exception') => $dumped_ret
    };
  }
  
  1;
TAK_EVALSERVICE

$fatpacked{"Tak/JSONChannel.pm"} = <<'TAK_JSONCHANNEL';
  package Tak::JSONChannel;
  
  use JSON::PP qw(encode_json decode_json);
  use IO::Handle;
  use Scalar::Util qw(weaken);
  use Log::Contextual qw(:log);
  use Moo;
  
  has read_fh => (is => 'ro', required => 1);
  has write_fh => (is => 'ro', required => 1);
  
  has _read_buf => (is => 'ro', default => sub { my $x = ''; \$x });
  
  sub BUILD { shift->write_fh->autoflush(1); }
  
  sub read_messages {
    my ($self, $cb) = @_;
    my $rb = $self->_read_buf;
    if (sysread($self->read_fh, $$rb, 1024, length($$rb)) > 0) {
      while ($$rb =~ s/^(.*)\n//) {
        my $line = $1;
        log_trace { "Received $line" };
        if (my $unpacked = $self->_unpack_line($line)) {
          $cb->(@$unpacked);
        }
      }
    } else {
      log_trace { "Closing" };
      $cb->('close', 'channel');
    }
  }
  
  sub _unpack_line {
    my ($self, $line) = @_;
    my $data = eval { decode_json($line) };
    unless ($data) {
      $self->write_message(mistake => invalid_json => $@||'No data and no exception');
      return;
    }
    unless (ref($data) eq 'ARRAY') {
      $self->write_message(mistake => message_format => "Not an ARRAY");
      return;
    }
    unless (@$data > 0) {
      $self->write_message(mistake => message_format => "Empty request array");
      return;
    }
    $data;
  }
  
  sub write_message {
    my ($self, @msg) = @_;
    my $json = eval { encode_json(\@msg) };
    unless ($json) {
      $self->_raw_write_message(
        encode_json(
          [ failure => invalid_message => $@||'No data and no exception' ]
        )
      );
      return;
    }
    log_trace { "Sending: $json" };
    $self->_raw_write_message($json);
  }
  
  sub _raw_write_message {
    my ($self, $raw) = @_;
  #warn "Sending: ${raw}\n";
    print { $self->write_fh } $raw."\n"
      or log_error { "Error writing: $!" };
  }
  
  1;
TAK_JSONCHANNEL

$fatpacked{"Tak/Loop.pm"} = <<'TAK_LOOP';
  package Tak::Loop;
  
  use IO::Select;
  use Moo;
  
  has is_running => (is => 'rw', clearer => 'loop_stop');
  
  has _read_watches => (is => 'ro', default => sub { {} });
  has _read_select => (is => 'ro', default => sub { IO::Select->new });
  
  sub pass_watches_to {
    my ($self, $new_loop) = @_;
    foreach my $fh ($self->_read_select->handles) {
      $new_loop->watch_io(
        handle => $fh,
        on_read_ready => $self->_read_watches->{$fh}
      );
    }
  }
  
  sub watch_io {
    my ($self, %watch) = @_;
    my $fh = $watch{handle};
    if (my $cb = $watch{on_read_ready}) {
      $self->_read_select->add($fh);
      $self->_read_watches->{$fh} = $cb;
    }
  }
  
  sub unwatch_io {
    my ($self, %watch) = @_;
    my $fh = $watch{handle};
    if ($watch{on_read_ready}) {
      $self->_read_select->remove($fh);
      delete $self->_read_watches->{$fh};
    }
  }
  
  sub loop_once {
    my ($self) = @_;
    my $read = $self->_read_watches;
    my ($readable) = IO::Select->select($self->_read_select, undef, undef, 0.5);
    # I would love to trap errors in the select call but IO::Select doesn't
    # differentiate between an error and a timeout.
    #   -- no, love, mst.
    foreach my $fh (@$readable) {
      $read->{$fh}();
    }
  }
  
  sub loop_forever {
    my ($self) = @_;
    $self->is_running(1);
    while ($self->is_running) {
      $self->loop_once;
    }
  }
  
  1;
TAK_LOOP

$fatpacked{"Tak/MetaService.pm"} = <<'TAK_METASERVICE';
  package Tak::MetaService;
  
  use Tak::WeakClient;
  use Log::Contextual qw(:log);
  use Moo;
  
  with 'Tak::Role::Service';
  
  has router => (is => 'ro', required => 1, weak_ref => 1);
  
  sub handle_pid {
    return $$;
  }
  
  sub handle_ensure {
    my $self = shift;
    my ($name) = @_;
    return "Already have ${name}" if $self->router->services->{$name};
    $self->handle_register(@_);
  }
  
  sub handle_register {
    my ($self, $name, $class, %args) = @_;
    (my $file = $class) =~ s/::/\//g;
    require "${file}.pm";
    if (my $expose = delete $args{expose}) {
      %args = (%args, %{$self->_construct_exposed_clients($expose)});
    }
    my $new = $class->new(\%args);
    $self->router->register($name => $new);
    return "Registered ${name}";
  }
  
  sub _construct_exposed_clients {
    my ($self, $expose) = @_;
    my $router = $self->router;
    my %client;
    foreach my $name (keys %$expose) {
      local $_ = $expose->{$name};
      if (ref eq 'HASH') {
        $client{$name} = Tak::Client->new(
           service => Tak::Router->new(
             services => $self->_construct_exposed_clients($_)
           )
        );
      } elsif (ref eq 'ARRAY') {
        if (my ($svc, @rest) = @$_) {
          die "router has no service ${svc}"
            unless my $service = $router->services->{$svc};
          my $client_class = (
            Scalar::Util::isweak($router->services->{$svc})
              ? 'Tak::WeakClient'
              : 'Tak::Client'
          );
          $client{$name} = $client_class->new(service => $service)
                                        ->curry(@rest);
        } else {
          $client{$name} = Tak::WeakClient->new(service => $router);
        }
      } else {
        die "expose key ${name} was ".ref;
      }
    }
    \%client;
  }
  
  1;
TAK_METASERVICE

$fatpacked{"Tak/ModuleLoader.pm"} = <<'TAK_MODULELOADER';
  package Tak::ModuleLoader;
  
  use Tak::ModuleLoader::Hook;
  use Moo;
  
  with 'Tak::Role::Service';
  
  has module_sender => (is => 'ro', required => 1);
  
  has inc_hook => (is => 'lazy');
  
  sub _build_inc_hook {
    my ($self) = @_;
    Tak::ModuleLoader::Hook->new(sender => $self->module_sender);
  }
  
  sub handle_enable {
    my ($self) = @_;
    push @INC, $self->inc_hook;
    return 'enabled';
  }
  
  sub handle_disable {
    my ($self) = @_;
    my $hook = $self->inc_hook;
    @INC = grep $_ ne $hook, @INC;
    return 'disabled';
  }
  
  sub DEMOLISH {
    my ($self) = @_;
    $self->handle_disable;
  }
  
  1;
TAK_MODULELOADER

$fatpacked{"Tak/ModuleLoader/Hook.pm"} = <<'TAK_MODULELOADER_HOOK';
  package Tak::ModuleLoader::Hook;
  
  use Moo;
  
  has sender => (is => 'ro', required => 1, weak_ref => 1);
  
  sub Tak::ModuleLoader::Hook::INC { # unqualified INC forced into package main
    my ($self, $module) = @_;
    my $result = $self->sender->result_of(source_for => $module);
    if ($result->is_success) {
      my $code = $result->get;
      open my $fh, '<', \$code;
      return $fh;
    }
    return;
  }
  
  1;
TAK_MODULELOADER_HOOK

$fatpacked{"Tak/ModuleSender.pm"} = <<'TAK_MODULESENDER';
  package Tak::ModuleSender;
  
  use IO::All;
  use List::Util qw(first);
  use Config;
  use Moo;
  
  with 'Tak::Role::Service';
  
  has dir_list => (is => 'lazy');
  
  sub _build_dir_list {
    my %core = map +($_ => 1), @Config{qw(privlibexp archlibexp)};
    [ map io->dir($_), grep !/$Config{archname}$/, grep !$core{$_}, @INC ];
  }
  
  sub handle_source_for {
    my ($self, $module) = @_;
    my $io = first { $_->exists } map $_->catfile($module), @{$self->dir_list};
    unless ($io) {
      die [ 'failure' ];
    }
    my $code = $io->all;
    return $code;
  }
  
  1;
TAK_MODULESENDER

$fatpacked{"Tak/MyScript.pm"} = <<'TAK_MYSCRIPT';
  package Tak::MyScript;
  
  use Moo;
  
  extends 'Tak::Script';
  
  sub _my_script_package { 'Tak::MyScript' }
  
  sub BUILD {
    my ($self) = @_;
    $self->_load_file('Takfile') if -e 'Takfile';
  }
  
  sub _load_file_in_my_script {
    require $_[1];
  }
  
  1;
TAK_MYSCRIPT

$fatpacked{"Tak/ObjectClient.pm"} = <<'TAK_OBJECTCLIENT';
  package Tak::ObjectClient;
  
  use Tak::ObjectProxy;
  use Moo;
  
  with 'Tak::Role::ObjectMangling';
  
  has remote => (is => 'ro', required => 1);
  
  has object_service => (is => 'lazy');
  
  sub _build_object_service {
    my ($self) = @_;
    my $remote = $self->remote;
    $remote->ensure(object_service => 'Tak::ObjectService');
    $remote->curry('object_service');
  }
  
  sub proxy_method_call {
    my ($self, @call) = @_;
    my $client = $self->object_service;
    my $ready = $self->encode_objects(\@call);
    my $context = wantarray;
    my $res = $client->do(call_method => $context => $ready);
    my $unpacked = $self->decode_objects($res);
    if ($context) {
      return @$unpacked;
    } elsif (defined $context) {
      return $unpacked->[0];
    } else {
      return;
    }
  }
  
  sub proxy_death {
    my ($self, $proxy) = @_;
    $self->client->do(remove_object => $proxy->{tag});
  }
  
  sub inflate {
    my ($self, $tag) = @_;
    bless({ client => $self, tag => $tag }, 'Tak::ObjectProxy');
  }
  
  sub deflate {
    my ($self, $obj) = @_;
    unless (ref($obj) eq 'Tak::ObjectProxy') {
      die "Can't deflate non-proxied object ${obj}";
    }
    return +{ __proxied_object__ => $obj->{tag} };
  }
  
  sub new_object {
    my ($self, $class, @args) = @_;
    $self->proxy_method_call($class, 'new', @args);
  }
  
  1;
TAK_OBJECTCLIENT

$fatpacked{"Tak/ObjectProxy.pm"} = <<'TAK_OBJECTPROXY';
  package Tak::ObjectProxy;
  
  use strictures 1;
  
  sub AUTOLOAD {
    my $self = shift;
    (my $method) = (our $AUTOLOAD =~ /([^:]+)$/);
    $self->{client}->proxy_method_call($self, $method => @_);
  }
  
  sub DESTROY {
    my $self = shift;
    $self->{client}->proxy_death($self);
  }
  
  1;
TAK_OBJECTPROXY

$fatpacked{"Tak/ObjectService.pm"} = <<'TAK_OBJECTSERVICE';
  package Tak::ObjectService;
  
  use overload ();
  use Moo;
  
  with 'Tak::Role::Service';
  with 'Tak::Role::ObjectMangling';
  
  has proxied => (is => 'ro', init_arg => undef, default => sub { {} });
  
  sub inflate {
    my ($self, $tag) = @_;
    $self->proxied->{$tag};
  }
  
  sub deflate {
    my ($self, $obj) = @_;
    my $tag = overload::StrVal($obj);
    $self->proxied->{$tag} = $obj;
    return +{ __proxied_object__ => $tag };
  }
  
  sub handle_call_method {
    my ($self, $context, $call) = @_;
    my ($invocant, $method, @args) = @{$self->decode_objects($call)};
    my @res;
    eval {
      if (!ref($invocant)) {
        (my $file = $invocant) =~ s/::/\//g;
        require "${file}.pm";
      }
      if ($context) {
        @res = $invocant->$method(@args);
      } elsif (defined $context) {
        $res[0] = $invocant->$method(@args);
      } else {
        $invocant->$method(@args);
      }
      1;
    } or die [ failure => "$@" ];
    return $self->encode_objects(\@res);
  }
  
  sub handle_remove_object {
    my ($self, $tag) = @_;
    my $had = !!delete $self->proxied->{$tag};
    return $had;
  }
  
  1;
TAK_OBJECTSERVICE

$fatpacked{"Tak/REPL.pm"} = <<'TAK_REPL';
  package Tak::REPL;
  
  use Term::ReadLine;
  use Moo;
  
  has client => (is => 'ro', required => 1);
  
  sub run {
    my $client = $_[0]->client;
    my $read = Term::ReadLine->new('REPL');
  
    while (1) {
      my $line = $read->readline('re.pl$ ');
      last unless defined $line;
      next unless length $line;
      my $result = $client->do(eval => $line);
      print exists($result->{return})
              ? $result->{return}
              : "Error: ".$result->{exception};
      if ($result->{stdout}) {
        chomp($result->{stdout});
        print "STDOUT:\n${\$result->{stdout}}\n";
      }
      if ($result->{stderr}) {
        chomp($result->{stderr});
        print "STDERR:\n${\$result->{stderr}}\n";
      }
    }
  }
  
  1;
TAK_REPL

$fatpacked{"Tak/Request.pm"} = <<'TAK_REQUEST';
  package Tak::Request;
  
  use Tak::Result;
  use Moo;
  
  has on_progress => (is => 'ro');
  
  has on_result => (is => 'ro', required => 1);
  
  has is_done => (is => 'rw', default => sub { 0 });
  
  sub progress {
    my ($self, @report) = @_;
    if (my $cb = $self->on_progress) {
      $cb->(@report);
    }
  }
  
  sub result {
    my ($self, $type, @data) = @_;
    $self->is_done(1);
    $self->on_result->(Tak::Result->new(type => $type, data => \@data));
  }
  
  sub flatten {
    my ($self) = @_;
    return ($self->type, @{$self->data});
  }
  
  sub success { shift->result(success => @_) }
  sub mistake { shift->result(mistake => @_) }
  sub failure { shift->result(failure => @_) }
  sub fatal { shift->result(fatal => @_) }
  
  1;
TAK_REQUEST

$fatpacked{"Tak/Result.pm"} = <<'TAK_RESULT';
  package Tak::Result;
  
  use Moo;
  
  has type => (is => 'ro', required => 1);
  has data => (is => 'ro', required => 1);
  
  sub flatten { $_[0]->type, @{$_[0]->data} }
  
  sub is_success { $_[0]->type eq 'success' }
  
  sub get {
    my ($self) = @_;
    $self->throw unless $self->is_success;
    return wantarray ? @{$self->data} : $self->data->[0];
  }
  
  sub throw {
    my ($self) = @_;
    die $self->exception;
  }
  
  sub exception {
    my ($self) = @_;
    $self->type.': '.join ' ', @{$self->data};
  }
  
  1;
TAK_RESULT

$fatpacked{"Tak/Role/ObjectMangling.pm"} = <<'TAK_ROLE_OBJECTMANGLING';
  package Tak::Role::ObjectMangling;
  
  use Scalar::Util qw(weaken);
  use JSON::PP qw(encode_json decode_json);
  
  use Moo::Role;
  
  requires 'inflate';
  requires 'deflate';
  
  has encoder_json => (is => 'lazy');
  has decoder_json => (is => 'lazy');
  
  sub _build_encoder_json {
    JSON::PP->new->allow_nonref(1)->convert_blessed(1);
  }
  
  sub _build_decoder_json {
    my $self = shift;
    weaken($self);
    JSON::PP->new->allow_nonref(1)->filter_json_single_key_object(
      __proxied_object__ => sub { $self->inflate($_[0]) }
    );
  }
  
  sub encode_objects {
    my ($self, $data) = @_;
    local *UNIVERSAL::TO_JSON = sub { $self->deflate($_[0]) };
    decode_json($self->encoder_json->encode($data));
  }
  
  sub decode_objects {
    my ($self, $data) = @_;
    $self->decoder_json->decode(encode_json($data));
  }
  
TAK_ROLE_OBJECTMANGLING

$fatpacked{"Tak/Role/ScriptActions.pm"} = <<'TAK_ROLE_SCRIPTACTIONS';
  package Tak::Role::ScriptActions;
  
  use Moo::Role;
  no warnings::illegalproto;
  
  sub every_exec (stream|s) {
    my ($self, $remotes, $options, @command) = @_;
  
    my @requests;
  
    $_->ensure(command_service => 'Tak::CommandService') for @$remotes;
  
    foreach my $remote (@$remotes) {
      if ($options->{stream}) {
        my $stdout = $self->stdout;
        my $host = $remote->host;
        push @requests, $remote->start(
          {
            on_result => sub { $self->print_exec_result($remote, @_) },
            on_progress => sub {
              $stdout->print($host.' '.$_[0].': '.$_[1]);
              $stdout->print("\n") unless $_[1] =~ /\n\Z/;
            }
          },
          command_service => stream_exec => \@command
        );
      } else {
        push @requests, $remote->start(
          { on_result => sub { $self->print_exec_result($remote, @_) } },
          command_service => exec => \@command
        );
      }
    }
    Tak->await_all(@requests);
  }
  
  sub print_exec_result {
    my ($self, $remote, $result) = @_;
  
    my $res = eval { $result->get }
      or do {
        $self->stderr->print("Host ${\$remote->host}: Error: $@\n");
        return;
      };
  
    my $code = $res->{exit_code};
    $self->stdout->print(
      "Host ${\$remote->host}: ".($code ? "NOT OK ${code}" : "OK")."\n"
    );
    if ($res->{stderr}) {
      $self->stdout->print("Stderr:\n${\$res->{stderr}}\n");
    }
    if ($res->{stdout}) {
      $self->stdout->print("Stdout:\n${\$res->{stdout}}\n");
    }
  }
  
  sub each_repl (I=s@;m=s@;M=s@) {
    my ($self, $remote, $options) = @_;
    require Tak::REPL;
    require B;
    $remote->ensure(
      eval_service => 'Tak::EvalService',
      expose => { service_client => [] },
    );
    foreach my $lib (@{$options->{'I'}||[]}) {
      $remote->do(eval_service => eval => "lib->import(${\B::perlstring($lib)})");
    }
    foreach my $module (@{$options->{'m'}||[]}) {
      $remote->do(eval_service => eval => "use ${module} ()");
    }
    foreach my $spec (@{$options->{'M'}||[]}) {
      my ($module, $import) = split('=', $spec);
      my $extra = '';
      if ($import) {
        $extra = ' '.join(', ', map B::perlstring($_), split(',',$import));
      }
      $remote->do(eval_service => eval => "use ${module}${extra}");
    }
    Tak::REPL->new(client => $remote->curry('eval_service'))->run;
  }
  
  1;
TAK_ROLE_SCRIPTACTIONS

$fatpacked{"Tak/Role/Service.pm"} = <<'TAK_ROLE_SERVICE';
  package Tak::Role::Service;
  
  use Moo::Role;
  
  sub start_request {
    my ($self, $req, $type, @payload) = @_;
    unless ($type) {
      $req->mistake(request_type => "No request type given");
      return;
    }
    if (my $meth = $self->can("handle_${type}")) {
      my @result;
      if (eval { @result = $self->$meth(@payload); 1 }) {
        $req->success(@result);
      } else {
        if (ref($@) eq 'ARRAY') {
          $req->result(@{$@});
        } else {
          $req->failure(exception => $@);
        }
      }
    } elsif ($meth = $self->can("start_${type}_request")) {
      $self->$meth($req => @payload);
    } else {
      $req->mistake(request_type => "Unknown request type ${type}");
    }
  }
  
  sub receive {
    my ($self, $type, @payload) = @_;
    if (my $meth = $self->can("receive_${type}")) {
      $self->$meth(@payload);
    }
  }
  
  # This assumes that by default either services are not stateful
  # or do want to have persistent state. It's notably overriden by Router.
  
  sub clone_or_self { $_[0] }
  
  1;
TAK_ROLE_SERVICE

$fatpacked{"Tak/Router.pm"} = <<'TAK_ROUTER';
  package Tak::Router;
  
  use Tak::MetaService;
  use Scalar::Util qw(weaken);
  use Log::Contextual qw(:log);
  use Moo;
  
  has services => (is => 'ro', default => sub { {} });
  
  sub BUILD {
    my ($self) = @_;
    $self->register(meta => Tak::MetaService->new(router => $self));
  }
  
  sub start_request {
    my ($self, $req, $target, @payload) = @_;
    return $req->mistake("Reached router with no target")
      unless $target;
    return $req->failure("Reached router with invalid target ${target}")
      unless my $next = $self->services->{$target};
    $next->start_request($req, @payload);
  }
  
  sub receive {
    my ($self, $target, @payload) = @_;
    return unless $target;
    log_debug { "Message received for ${target}" };
    return log_info { "Discarded message to ${target}" }
      unless my $next = $self->services->{$target};
    $next->receive(@payload);
  }
  
  sub register {
    my ($self, $name, $service) = @_;
    $self->services->{$name} = $service;
  }
  
  sub register_weak {
    my ($self, $name, $service) = @_;
    weaken($self->services->{$name} = $service);
  }
  
  sub deregister {
    my ($self, $name) = @_;
    delete $self->services->{$name}
  }
  
  sub clone_or_self {
    my ($self) = @_;
    (ref $self)->new(services => { %{$self->services} });
  }
  
  1;
TAK_ROUTER

$fatpacked{"Tak/STDIONode.pm"} = <<'TAK_STDIONODE';
  package Tak::STDIONode;
  our $DATA = do { local $/; <DATA> };
  1;
  __DATA__
  
TAK_STDIONODE

$fatpacked{"Tak/STDIOSetup.pm"} = <<'TAK_STDIOSETUP';
  package Tak::STDIOSetup;
  
  use Log::Contextual qw(:log);
  use Log::Contextual::SimpleLogger;
  use Tak::ConnectionService;
  use Tak::Router;
  use Tak;
  use IO::Handle;
  use strictures 1;
  
  sub run {
    open my $stdin, '<&', \*STDIN or die "Duping stdin: $!";
    open my $stdout, '>&', \*STDOUT or die "Duping stdout: $!";
    $stdout->autoflush(1);
    # if we don't re-open them then 0 and 1 get re-used - which is not
    # only potentially bloody confusing but results in warnings like:
    # "Filehandle STDOUT reopened as STDIN only for input"
    close STDIN or die "Closing stdin: $!";
    open STDIN, '<', '/dev/null' or die "Re-opening stdin: $!";
    close STDOUT or die "Closing stdout: $!";
    open STDOUT, '>', '/dev/null' or die "Re-opening stdout: $!";
    my ($host, $level) = @ARGV;
    my $sig = '<'.join ':', $host, $$.'> ';
    Log::Contextual::set_logger(
      Log::Contextual::SimpleLogger->new({
        levels_upto => $level,
        coderef => sub { print STDERR $sig, @_; }
      })
    );
    my $done;
    my $connection = Tak::ConnectionService->new(
      read_fh => $stdin, write_fh => $stdout,
      listening_service => Tak::Router->new,
      on_close => sub { $done = 1 }
    );
    $connection->receiver->service->register_weak(remote => $connection);
    $0 = 'tak-stdio-node';
    log_debug { "Node starting" };
    # Tell the other end that we've finished messing around with file
    # descriptors and that it's therefore safe to start sending requests.
    print $stdout "Ssyshere\n";
    Tak->loop_until($done);
    if (our $Next) { goto &$Next }
  }
  
  1;
TAK_STDIOSETUP

$fatpacked{"Tak/Script.pm"} = <<'TAK_SCRIPT';
  package Tak::Script;
  
  use Getopt::Long qw(GetOptionsFromArray :config posix_defaults bundling);
  use Config::Settings;
  use IO::Handle;
  use Tak::Client::Router;
  use Tak::Client::RemoteRouter;
  use Tak::Router;
  use Log::Contextual qw(:log);
  use Log::Contextual::SimpleLogger;
  use Moo;
  
  with 'Tak::Role::ScriptActions';
  
  has options => (is => 'ro', required => 1);
  has env => (is => 'ro', required => 1);
  
  has log_level => (is => 'rw');
  
  has stdin => (is => 'lazy');
  has stdout => (is => 'lazy');
  has stderr => (is => 'lazy');
  
  sub _build_stdin { shift->env->{stdin} }
  sub _build_stdout { shift->env->{stdout} }
  sub _build_stderr { shift->env->{stderr} }
  
  has config => (is => 'lazy');
  
  sub _build_config {
    my ($self) = @_;
    my $file = $self->options->{config} || '.tak/default.conf';
    if (-e $file) {
      Config::Settings->new->parse_file($file);
    } else {
      {};
    }
  }
  
  has local_client => (is => 'lazy');
  
  sub _build_local_client {
    my ($self) = @_;
    Tak::Client::Router->new(service => Tak::Router->new);
  }
  
  sub BUILD {
    shift->setup_logger;
  }
  
  sub setup_logger {
    my ($self) = @_;
    my @level_names = qw(fatal error warn info debug trace);
    my $options = $self->options;
    my $level = 2 + ($options->{verbose}||0) - ($options->{quiet}||0);
    my $upto = $level_names[$level];
    $self->log_level($upto);
    Log::Contextual::set_logger(
      Log::Contextual::SimpleLogger->new({
        levels_upto => $upto,
        coderef => sub { print STDERR '<local> ', @_ },
      })
    );
  }
  
  sub _parse_options {
    my ($self, $string, $argv) = @_;
    my @spec = split ';', $string;
    my %opt;
    GetOptionsFromArray($argv, \%opt, @spec);
    return \%opt;
  }
  
  sub run {
    my ($self) = @_;
    my @argv = @{$self->env->{argv}};
    unless (@argv && $argv[0]) {
      return $self->local_help;
    }
    my $cmd = shift(@argv);
    $cmd =~ s/-/_/g;
    if (my $code = $self->can("local_$cmd")) {
      return $self->_run($cmd, $code, @argv);
    } elsif ($code = $self->can("each_$cmd")) {
      return $self->_run_each($cmd, $code, @argv);
    } elsif ($code = $self->can("every_$cmd")) {
      return $self->_run_every($cmd, $code, @argv);
    }
    $self->stderr->print("No such command: ${cmd}\n");
    return $self->local_help;
  }
  
  sub _load_file {
    my ($self, $file) = @_;
    $self->_load_file_in_my_script($file);
  }
  
  sub local_help {
    my ($self) = @_;
    $self->stderr->print("Help unimplemented\n");
  }
  
  sub _maybe_parse_options {
    my ($self, $code, $argv) = @_;
    if (my $proto = prototype($code)) {
      $self->_parse_options($proto, $argv);
    } else {
      {};
    }
  }
  
  sub _run_local {
    my ($self, $cmd, $code, @argv) = @_;
    my $opt = $self->_maybe_parse_options($code, \@argv);
    $self->$code($opt, @argv);
  }
  
  sub _run_each {
    my ($self, $cmd, $code, @argv) = @_;
    my @targets = $self->_host_list_for($cmd);
    unless (@targets) {
      $self->stderr->print("No targets for ${cmd}\n");
      return;
    }
    my $opt = $self->_maybe_parse_options($code, \@argv);
    $self->local_client->ensure(connector => 'Tak::ConnectorService');
    foreach my $target (@targets) {
      my $remote = $self->_connection_to($target);
      $self->$code($remote, $opt, @argv);
    }
  }
  
  sub _run_every {
    my ($self, $cmd, $code, @argv) = @_;
    my @targets = $self->_host_list_for($cmd);
    unless (@targets) {
      $self->stderr->print("No targets for ${cmd}\n");
      return;
    }
    my $opt = $self->_maybe_parse_options($code, \@argv);
    $self->local_client->ensure(connector => 'Tak::ConnectorService');
    my @remotes = map $self->_connection_to($_), @targets;
    $self->$code(\@remotes, $opt, @argv);
  }
  
  sub _host_list_for {
    my ($self, $command) = @_;
    my @host_spec = map split(' ', $_), @{$self->options->{host}};
    unshift(@host_spec, '-') if $self->options->{local};
    return @host_spec;
  }
  
  sub _connection_to {
    my ($self, $target) = @_;
    log_debug { "Connecting to ${target}" };
    my @path = $self->local_client->do(
      connector => create => $target, log_level => $self->log_level
    );
    my ($local, $remote) =
      map $self->local_client->curry(connector => connection => @path => $_),
        qw(local remote);
    $local->ensure(module_sender => 'Tak::ModuleSender');
    $remote->ensure(
      module_loader => 'Tak::ModuleLoader',
      expose => { module_sender => [ 'remote', 'module_sender' ] }
    );
    $remote->do(module_loader => 'enable');
    log_debug { "Setup connection to ${target}" };
    Tak::Client::RemoteRouter->new(
      %$remote, host => $target
    );
  }
  
  1;
TAK_SCRIPT

$fatpacked{"Tak/Takfile.pm"} = <<'TAK_TAKFILE';
  package Tak::Takfile;
  
  use strictures 1;
  use warnings::illegalproto ();
  
  sub import {
    strictures->import;
    warnings::illegalproto->unimport;
  }
  
  1;
TAK_TAKFILE

$fatpacked{"Tak/WeakClient.pm"} = <<'TAK_WEAKCLIENT';
  package Tak::WeakClient;
  
  use Moo;
  
  extends 'Tak::Client';
  
  has service => (is => 'ro', required => 1, weak_ref => 1);
  
  sub clone_or_self {
    my ($self) = @_;
    my $new = $self->service->clone_or_self;
    ($new ne $self->service
      ? 'Tak::Client'
      : ref($self))->new(service => $new, curried => [ @{$self->curried} ]);
  }
      
  
  1;
TAK_WEAKCLIENT

$fatpacked{"aliased.pm"} = <<'ALIASED';
  package aliased;
  $VERSION = '0.30';
  
  require Exporter;
  @ISA    = qw(Exporter);
  @EXPORT = qw(alias);
  
  use strict;
  
  sub import {
      my ( $class, $package, $alias, @import ) = @_;
  
      if ( @_ <= 1 ) {
          $class->export_to_level(1);
          return;
      }
  
      my $callpack = caller(0);
  
      _load_alias( $package, $callpack, @import );
      _make_alias( $package, $callpack, $alias );
  }
  
  sub _get_alias {
      my $package = shift;
      $package =~ s/.*(?:::|')//;
      return $package;
  }
  
  sub _make_alias {
      my ( $package, $callpack, $alias ) = @_;
  
      $alias ||= _get_alias($package);
  
      no strict 'refs';
      *{ join q{::} => $callpack, $alias } = sub () { $package };
  }
  
  sub _load_alias {
      my ( $package, $callpack, @import ) = @_;
  
      # We don't localize $SIG{__DIE__} here because we need to be careful about
      # restoring its value if there is a failure.  Very, very tricky.
      my $sigdie = $SIG{__DIE__};
      {
          my $code =
            @import == 0
            ? "package $callpack; use $package;"
            : "package $callpack; use $package (\@import)";
          eval $code;
          if ( my $error = $@ ) {
              $SIG{__DIE__} = $sigdie;
              die $error;
          }
          $sigdie = $SIG{__DIE__}
            if defined $SIG{__DIE__};
      }
  
      # Make sure a global $SIG{__DIE__} makes it out of the localization.
      $SIG{__DIE__} = $sigdie if defined $sigdie;
  }
  
  sub alias {
      my ( $package, @import ) = @_;
  
      my $callpack = scalar caller(0);
      _load_alias( $package, $callpack, @import );
  
      return $package;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  aliased - Use shorter versions of class names.
  
  =head1 VERSION
  
  0.30
  
  =head1 SYNOPSIS
  
    # Class name interface
    use aliased 'My::Company::Namespace::Customer';
    my $cust = Customer->new;
  
    use aliased 'My::Company::Namespace::Preferred::Customer' => 'Preferred';
    my $pref = Preferred->new;
  
  
    # Variable interface
    use aliased;
    my $Customer  = alias "My::Other::Namespace::Customer";
    my $cust      = $Customer->new;
  
    my $Preferred = alias "My::Other::Namespace::Preferred::Customer";
    my $pref      = $Preferred->new;  
  
  
  =head1 DESCRIPTION
  
  C<aliased> is simple in concept but is a rather handy module.  It loads the
  class you specify and exports into your namespace a subroutine that returns
  the class name.  You can explicitly alias the class to another name or, if you
  prefer, you can do so implicitly.  In the latter case, the name of the
  subroutine is the last part of the class name.  Thus, it does something
  similar to the following:
  
    #use aliased 'Some::Annoyingly::Long::Module::Name::Customer';
  
    use Some::Annoyingly::Long::Module::Name::Customer;
    sub Customer {
      return 'Some::Annoyingly::Long::Module::Name::Customer';
    }
    my $cust = Customer->new;
  
  This module is useful if you prefer a shorter name for a class.  It's also
  handy if a class has been renamed.
  
  (Some may object to the term "aliasing" because we're not aliasing one
  namespace to another, but it's a handy term.  Just keep in mind that this is
  done with a subroutine and not with typeglobs and weird namespace munging.)
  
  Note that this is B<only> for C<use>ing OO modules.  You cannot use this to
  load procedural modules.  See the L<Why OO Only?|Why OO Only?> section.  Also,
  don't let the version number fool you.  This code is ridiculously simple and
  is just fine for most use.
  
  =head2 Implicit Aliasing
  
  The most common use of this module is:
  
    use aliased 'Some::Module::name';
  
  C<aliased> will  allow you to reference the class by the last part of the
  class name.  Thus, C<Really::Long::Name> becomes C<Name>.  It does this by
  exporting a subroutine into your namespace with the same name as the aliased
  name.  This subroutine returns the original class name.
  
  For example:
  
    use aliased "Acme::Company::Customer";
    my $cust = Customer->find($id);
  
  Note that any class method can be called on the shorter version of the class
  name, not just the constructor.
  
  =head2 Explicit Aliasing
  
  Sometimes two class names can cause a conflict (they both end with C<Customer>
  for example), or you already have a subroutine with the same name as the
  aliased name.  In that case, you can make an explicit alias by stating the
  name you wish to alias to:
  
    use aliased 'Original::Module::Name' => 'NewName';
  
  Here's how we use C<aliased> to avoid conflicts:
  
    use aliased "Really::Long::Name";
    use aliased "Another::Really::Long::Name" => "Aname";
    my $name  = Name->new;
    my $aname = Aname->new;
  
  You can even alias to a different package:
  
    use aliased "Another::Really::Long::Name" => "Another::Name";
    my $aname = Another::Name->new;
  
  Messing around with different namespaces is a really bad idea and you probably
  don't want to do this.  However, it might prove handy if the module you are
  using has been renamed.  If the interface has not changed, this allows you to
  use the new module by only changing one line of code.
  
    use aliased "New::Module::Name" => "Old::Module::Name";
    my $thing = Old::Module::Name->new;
  
  =head2 Import Lists
  
  Sometimes, even with an OO module, you need to specify extra arguments when
  using the module.  When this happens, simply use L<Explicit Aliasing> followed
  by the import list:
  
  Snippet 1:
  
    use Some::Module::Name qw/foo bar/;
    my $o = Some::Module::Name->some_class_method; 
  
  Snippet 2 (equivalent to snippet 1):
  
    use aliased 'Some::Module::Name' => 'Name', qw/foo bar/;
    my $o = Name->some_class_method;
  
  B<Note>:  remember, you cannot use import lists with L<Implicit Aliasing>.  As
  a result, you may simply prefer to only use L<Explicit Aliasing> as a matter
  of style.
  
  =head2 alias()
  
      my $alias = alias($class);
      my $alias = alias($class, @imports);
  
  alias() is an alternative to C<use aliased ...> which uses less magic and
  avoids some of the ambiguities.
  
  Like C<use aliased> it C<use>s the $class (pass in @imports, if given) but
  instead of providing an C<Alias> constant it simply returns a scalar set to
  the $class name.
  
      my $thing = alias("Some::Thing::With::A::Long::Name");
  
      # Just like Some::Thing::With::A::Long::Name->method
      $thing->method;
  
  The use of a scalar instead of a constant avoids any possible ambiguity
  when aliasing two similar names:
  
      # No ambiguity despite the fact that they both end with "Name"
      my $thing = alias("Some::Thing::With::A::Long::Name");
      my $other = alias("Some::Other::Thing::With::A::Long::Name");
  
  and there is no magic constant exported into your namespace.
  
  The only caveat is loading of the $class happens at run time.  If $class
  exports anything you might want to ensure it is loaded at compile time with:
  
      my $thing;
      BEGIN { $thing = alias("Some::Thing"); }
  
  However, since OO classes rarely export this should not be necessary.
  
  
  =head2 Why OO Only?
  
  Some people have asked why this code only support object-oriented modules
  (OO).  If I were to support normal subroutines, I would have to allow the
  following syntax:
  
    use aliased 'Some::Really::Long::Module::Name';
    my $data = Name::data();
  
  That causes a serious problem.  The only (reasonable) way it can be done is to
  handle the aliasing via typeglobs.  Thus, instead of a subroutine that
  provides the class name, we alias one package to another (as the
  L<namespace|namespace> module does.)  However, we really don't want to simply
  alias one package to another and wipe out namespaces willy-nilly.  By merely
  exporting a single subroutine to a namespace, we minimize the issue. 
  
  Fortunately, this doesn't seem to be that much of a problem.  Non-OO modules
  generally support exporting of the functions you need and this eliminates the
  need for a module such as this.
  
  =head1 EXPORT
  
  This modules exports a subroutine with the same name as the "aliased" name.
  
  =head1 BUGS
  
  There are no known bugs in this module, but feel free to email me reports.
  
  =head1 SEE ALSO
  
  The L<namespace> module.
  
  =head1 THANKS
  
  Many thanks to Rentrak, Inc. (http://www.rentrak.com/) for graciously allowing
  me to replicate the functionality of some of their internal code.
  
  =head1 AUTHOR
  
  Curtis Poe, C<< ovid [at] cpan [dot] org >>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2005 by Curtis "Ovid" Poe
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.8.5 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
ALIASED

$fatpacked{"oo.pm"} = <<'OO';
  package oo;
  
  use strictures 1;
  use Moo::_Utils;
  
  sub moo {
    print <<'EOMOO';
   ______
  < Moo! >
   ------
          \   ^__^
           \  (oo)\_______
              (__)\       )\/\
                  ||----w |
                  ||     ||
  EOMOO
    exit 0;
  }
  
  BEGIN {
      my $package;
      sub import {
          moo() if $0 eq '-';
          $package = $_[1] || 'Class';
          if ($package =~ /^\+/) {
              $package =~ s/^\+//;
              _load_module($package);
          }
      }
      use Filter::Simple sub { s/^/package $package;\nuse Moo;\n/; }
  }
  
  1;
OO

$fatpacked{"strictures.pm"} = <<'STRICTURES';
  package strictures;
  
  use strict;
  use warnings FATAL => 'all';
  
  our $VERSION = '1.002002'; # 1.2.2
  
  sub VERSION {
    for ($_[1]) {
      last unless defined && !ref && int != 1;
      die "Major version specified as $_ - this is strictures version 1";
    }
    # disable this since Foo->VERSION(undef) correctly returns the version
    # and that can happen either if our caller passes undef explicitly or
    # because the for above autovivified $_[1] - I could make it stop but
    # it's pointless since we don't want to blow up if the caller does
    # something valid either.
    no warnings 'uninitialized';
    shift->SUPER::VERSION(@_);
  }
  
  sub import {
    strict->import;
    warnings->import(FATAL => 'all');
    my $extra_tests = do {
      if (exists $ENV{PERL_STRICTURES_EXTRA}) {
        $ENV{PERL_STRICTURES_EXTRA}
      } else {
        !!($0 =~ /^x?t\/.*(?:load|compile|coverage|use_ok).*\.t$/
           and (-e '.git' or -e '.svn'))
      }
    };
    if ($extra_tests) {
      if (eval {
            require indirect;
            require multidimensional;
            require bareword::filehandles;
            1
          }) {
        indirect->unimport(':fatal');
        multidimensional->unimport;
        bareword::filehandles->unimport;
      } else {
        die "strictures.pm extra testing active but couldn't load modules.
  Extra testing is auto-enabled in checkouts only, so if you're the author
  of a strictures using module you need to run:
  
    cpan indirect multidimensional bareword::filehandles
  
  but these modules are not required by your users.
  
  Error loading modules was: $@";
      }
    }
  }
  
  1;
  
  __END__
  =head1 NAME
  
  strictures - turn on strict and make all warnings fatal
  
  =head1 SYNOPSIS
  
    use strictures 1;
  
  is equivalent to
  
    use strict;
    use warnings FATAL => 'all';
  
  except when called from a file where $0 matches:
  
    /^x?t\/.*(?:load|compile|coverage|use_ok).*\.t$/
  
  and when either '.git' or '.svn' is present in the current directory (with
  the intention of only forcing extra tests on the author side) - or when the
  PERL_STRICTURES_EXTRA environment variable is set, in which case
  
    use strictures 1;
  
  is equivalent to
  
    use strict;
    use warnings FATAL => 'all';
    no indirect 'fatal';
    no multidimensional;
    no bareword::filehandles;
  
  Note that _EXTRA may at some point add even more tests, with only a minor
  version increase, but any changes to the effect of 'use strictures' in
  normal mode will involve a major version bump.
  
  Be aware: THIS MEANS THE EXTRA TEST MODULES ARE REQUIRED FOR AUTHORS OF
  STRICTURES USING CODE - but not by end users thereof.
  
  =head1 DESCRIPTION
  
  I've been writing the equivalent of this module at the top of my code for
  about a year now. I figured it was time to make it shorter.
  
  Things like the importer in 'use Moose' don't help me because they turn
  warnings on but don't make them fatal - which from my point of view is
  useless because I want an exception to tell me my code isn't warnings clean.
  
  Any time I see a warning from my code, that indicates a mistake.
  
  Any time my code encounters a mistake, I want a crash - not spew to STDERR
  and then unknown (and probably undesired) subsequent behaviour.
  
  I also want to ensure that obvious coding mistakes, like indirect object
  syntax (and not so obvious mistakes that cause things to accidentally compile
  as such) get caught, but not at the cost of an XS dependency and not at the
  cost of blowing things up on another machine.
  
  Therefore, strictures turns on indirect checking only when it thinks it's
  running in a compilation (or pod coverage) test - though if this causes
  undesired behaviour this can be overridden by setting the
  PERL_STRICTURES_EXTRA environment variable.
  
  If additional useful author side checks come to mind, I'll add them to the
  _EXTRA code path only - this will result in a minor version increase (i.e.
  1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the mechanism of
  this code will result in a subversion increas (i.e. 1.000000 to 1.000001
  (1.0.1)).
  
  If the behaviour of 'use strictures' in normal mode changes in any way, that
  will constitute a major version increase - and the code already checks
  when its version is tested to ensure that
  
    use strictures 1;
  
  will continue to only introduce the current set of strictures even if 2.0 is
  installed.
  
  =head1 METHODS
  
  =head2 import
  
  This method does the setup work described above in L</DESCRIPTION>
  
  =head2 VERSION
  
  This method traps the strictures->VERSION(1) call produced by a use line
  with a version number on it and does the version check.
  
  =head1 COMMUNITY AND SUPPORT
  
  =head2 IRC channel
  
  irc.perl.org #toolchain
  
  (or bug 'mst' in query on there or freenode)
  
  =head2 Git repository
  
  Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
  
    git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  None required yet. Maybe this module is perfect (hahahahaha ...).
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
STRICTURES

s/^  //mg for values %fatpacked;

unshift @INC, sub {
  if (my $fat = $fatpacked{$_[1]}) {
    open my $fh, '<', \$fat
      or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
    return $fh;
  }
  return
};

} # END OF FATPACK CODE
#!/usr/bin/env perl

use Tak::STDIOSetup;
Tak::STDIOSetup->run;
