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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAPTURE_TINY';
  use 5.006;
  use strict;
  use warnings;
  package Capture::Tiny;
  # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
  our $VERSION = '0.27';
  use Carp ();
  use Exporter ();
  use IO::Handle ();
  use File::Spec ();
  use File::Temp qw/tempfile tmpnam/;
  use Scalar::Util qw/reftype blessed/;
  # Get PerlIO or fake it
  BEGIN {
    local $@;
    eval { require PerlIO; PerlIO->can('get_layers') }
      or *PerlIO::get_layers = sub { return () };
  }
  
  #--------------------------------------------------------------------------#
  # create API subroutines and export them
  # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
  #--------------------------------------------------------------------------#
  
  my %api = (
    capture         => [1,1,0,0],
    capture_stdout  => [1,0,0,0],
    capture_stderr  => [0,1,0,0],
    capture_merged  => [1,1,1,0],
    tee             => [1,1,0,1],
    tee_stdout      => [1,0,0,1],
    tee_stderr      => [0,1,0,1],
    tee_merged      => [1,1,1,1],
  );
  
  for my $sub ( keys %api ) {
    my $args = join q{, }, @{$api{$sub}};
    eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
  }
  
  our @ISA = qw/Exporter/;
  our @EXPORT_OK = keys %api;
  our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
  
  #--------------------------------------------------------------------------#
  # constants and fixtures
  #--------------------------------------------------------------------------#
  
  my $IS_WIN32 = $^O eq 'MSWin32';
  
  ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
  ##
  ##my $DEBUGFH;
  ##open $DEBUGFH, "> DEBUG" 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, '-C0', '-e', <<'HERE');
  use Fcntl;
  $SIG{HUP}=sub{exit};
  if ( my $fn=shift ) {
      sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
      print {$fh} $$;
      close $fh;
  }
  my $buf; while (sysread(STDIN, $buf, 2048)) {
      syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
  }
  HERE
  
  #--------------------------------------------------------------------------#
  # filehandle manipulation
  #--------------------------------------------------------------------------#
  
  sub _relayer {
    my ($fh, $layers) = @_;
    # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
    my %seen = ( unix => 1, perlio => 1 ); # filter these out
    my @unique = grep { !$seen{$_}++ } @$layers;
    # _debug("# applying unique layers (@unique) to @{[fileno $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 {
    # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' )  . " on " . fileno( $_[0] ) . "\n" );
    close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
  }
  
  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; ## no critic
    }
    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; ## no critic
    }
    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; ## no critic
    }
    return %proxies;
  }
  
  sub _unproxy {
    my (%proxies) = @_;
    # _debug( "# unproxying: " . 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;
    for my $h ( qw/stdout stderr stdin/ ) {
      next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
      my $redir = $h eq 'stdin' ? "<&" : ">&";
      _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
    }
    return \%handles;
  }
  
  # In some cases we open all (prior to forking) and in others we only open
  # the output handles (setting up redirection)
  sub _open_std {
    my ($handles) = @_;
    _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
    _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
    _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
  }
  
  #--------------------------------------------------------------------------#
  # private subs
  #--------------------------------------------------------------------------#
  
  sub _start_tee {
    my ($which, $stash) = @_; # $which is "stdout" or "stderr"
    # 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();
      my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
      # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# 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) = @_; # $which is "stdout" or "stderr"
    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
  }
  
  my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
  sub _files_exist {
    return 1 if @_ == grep { -f } @_;
    Time::HiRes::usleep(1000) if $have_usleep;
    return 0;
  }
  
  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 {
    my ($name, $stash) = @_;
    my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
    # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
    seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
    my $text = do { local $/; scalar readline $fh };
    return defined($text) ? $text : "";
  }
  
  #--------------------------------------------------------------------------#
  # _capture_tee() -- generic main sub for capturing or teeing
  #--------------------------------------------------------------------------#
  
  sub _capture_tee {
    # _debug( "# starting _capture_tee with (@_)...\n" );
    my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
    my %do = ($do_stdout ? (stdout => 1) : (),  $do_stderr ? (stderr => 1) : ());
    Carp::confess("Custom capture options must be given as key/value pairs\n")
      unless @opts % 2 == 0;
    my $stash = { capture => { @opts } };
    for ( keys %{$stash->{capture}} ) {
      my $fh = $stash->{capture}{$_};
      Carp::confess "Custom handle for $_ must be seekable\n"
        unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
    }
    # 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, output => 1)],
      stderr  => [PerlIO::get_layers(\*STDERR, output => 1)],
    );
    # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
    # get layers from underlying glob of tied filehandles if we can
    # (this only works for things that work like Tie::StdHandle)
    $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
      if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
    $layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
      if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
    # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
    # bypass scalar filehandles and tied handles
    # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
    my %localize;
    $localize{stdin}++,  local(*STDIN)
      if grep { $_ eq 'scalar' } @{$layers{stdin}};
    $localize{stdout}++, local(*STDOUT)
      if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
    $localize{stderr}++, local(*STDERR)
      if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
    $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
      if tied *STDIN && $] >= 5.008;
    $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
      if $do_stdout && tied *STDOUT && $] >= 5.008;
    $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
      if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
    # _debug( "# localized $_\n" ) for keys %localize;
    # proxy any closed/localized handles so we don't use fds 0, 1 or 2
    my %proxy_std = _proxy_std();
    # _debug( "# proxy std: @{ [%proxy_std] }\n" );
    # update layers after any proxying
    $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
    $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
    # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
    # store old handles and setup handles for capture
    $stash->{old} = _copy_std();
    $stash->{new} = { %{$stash->{old}} }; # default to originals
    for ( keys %do ) {
      $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
      seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
      $stash->{pos}{$_} = tell $stash->{capture}{$_};
      # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
      _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
    }
    _wait_for_tees( $stash ) if $do_tee;
    # finalize redirection
    $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
    # _debug( "# redirecting in parent ...\n" );
    _open_std( $stash->{new} );
    # execute user provided code
    my ($exit_code, $inner_error, $outer_error, @result);
    {
      local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
      # _debug( "# finalizing layers ...\n" );
      _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
      _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
      # _debug( "# running code $code ...\n" );
      local $@;
      eval { @result = $code->(); $inner_error = $@ };
      $exit_code = $?; # save this for later
      $outer_error = $@; # save this for later
    }
    # restore prior filehandles and shut down tees
    # _debug( "# restoring filehandles ...\n" );
    _open_std( $stash->{old} );
    _close( $_ ) for values %{$stash->{old}}; # don't leak fds
    # shouldn't need relayering originals, but see rt.perl.org #114404
    _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
    _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
    _unproxy( %proxy_std );
    # _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
    _kill_tees( $stash ) if $do_tee;
    # return captured output, but shortcut in void context
    # unless we have to echo output to tied/scalar handles;
    my %got;
    if ( defined wantarray or ($do_tee && keys %localize) ) {
      for ( keys %do ) {
        _relayer($stash->{capture}{$_}, $layers{$_});
        $got{$_} = _slurp($_, $stash);
        # _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
      }
      print CT_ORIG_STDOUT $got{stdout}
        if $do_stdout && $do_tee && $localize{stdout};
      print CT_ORIG_STDERR $got{stderr}
        if $do_stderr && $do_tee && $localize{stderr};
    }
    $? = $exit_code;
    $@ = $inner_error if $inner_error;
    die $outer_error if $outer_error;
    # _debug( "# ending _capture_tee with (@_)...\n" );
    return unless defined wantarray;
    my @return;
    push @return, $got{stdout} if $do_stdout;
    push @return, $got{stderr} if $do_stderr && ! $do_merge;
    push @return, @result;
    return wantarray ? @return : $return[0];
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
  
  =head1 VERSION
  
  version 0.27
  
  =head1 SYNOPSIS
  
     use Capture::Tiny ':all';
   
     # capture from external command
   
     ($stdout, $stderr, $exit) = capture {
       system( $cmd, @args );
     };
   
     # capture from arbitrary code (Perl or external)
   
     ($stdout, $stderr, @result) = capture {
       # your code here
     };
   
     # capture partial or merged output
   
     $stdout = capture_stdout { ... };
     $stderr = capture_stderr { ... };
     $merged = capture_merged { ... };
   
     # tee output
   
     ($stdout, $stderr) = tee {
       # your code here
     };
   
     $stdout = tee_stdout { ... };
     $stderr = tee_stderr { ... };
     $merged = tee_merged { ... };
  
  =head1 DESCRIPTION
  
  Capture::Tiny provides a simple, portable way to capture almost 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 filehandles.  Yes, it even
  works on Windows (usually).  Stop guessing which of a dozen capturing modules
  to use in any particular situation and just use this one.
  
  =head1 USAGE
  
  The following functions are available.  None are exported by default.
  
  =head2 capture
  
     ($stdout, $stderr, @result) = capture \&code;
     $stdout = capture \&code;
  
  The C<<< capture >>> function takes a code reference and returns what is sent to
  STDOUT and STDERR as well as any return values from the code reference.  In
  scalar context, it returns only STDOUT.  If no output was received for a
  filehandle, it returns an empty string for that filehandle.  Regardless of calling
  context, all output is captured -- nothing is passed to the existing filehandles.
  
  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 ...
     };
  
  Note that the coderef is evaluated in list context.  If you wish to force
  scalar context on the return value, you must use the C<<< scalar >>> keyword.
  
     ($stdout, $stderr, $count) = capture {
       my @list = qw/one two three/;
       return scalar @list; # $count will be 3
     };
  
  Also note that within the coderef, the C<<< @_ >>> variable will be empty.  So don't
  use arguments from a surrounding subroutine without copying them to an array
  first:
  
     sub wont_work {
       my ($stdout, $stderr) = capture { do_stuff( @_ ) };    # WRONG
       ...
     }
   
     sub will_work {
       my @args = @_;
       my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
       ...
     }
  
  Captures are normally done to an anonymous temporary filehandle.  To
  capture via a named file (e.g. to externally monitor a long-running capture),
  provide custom filehandles as a trailing list of option pairs:
  
     my $out_fh = IO::File->new("out.txt", "w+");
     my $err_fh = IO::File->new("out.txt", "w+");
     capture { ... } stdout => $out_fh, stderr => $err_fh;
  
  The filehandles must be readE<sol>write and seekable.  Modifying the files or
  filehandles during a capture operation will give unpredictable results.
  Existing IO layers on them may be changed by the capture.
  
  When called in void context, C<<< capture >>> saves memory and time by
  not reading back from the capture handles.
  
  =head2 capture_stdout
  
     ($stdout, @result) = capture_stdout \&code;
     $stdout = capture_stdout \&code;
  
  The C<<< capture_stdout >>> function works just like C<<< capture >>> except only
  STDOUT is captured.  STDERR is not captured.
  
  =head2 capture_stderr
  
     ($stderr, @result) = capture_stderr \&code;
     $stderr = capture_stderr \&code;
  
  The C<<< capture_stderr >>> function works just like C<<< capture >>> except only
  STDERR is captured.  STDOUT is not captured.
  
  =head2 capture_merged
  
     ($merged, @result) = capture_merged \&code;
     $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 the same capturing
  handle as STDOUT before executing the function.)
  
  Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
  properly ordered due to buffering.
  
  =head2 tee
  
     ($stdout, $stderr, @result) = 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.
  
  When called in void context, C<<< tee >>> saves memory and time by
  not reading back from the capture handles, except when the
  original STDOUT OR STDERR were tied or opened to a scalar
  handle.
  
  =head2 tee_stdout
  
     ($stdout, @result) = tee_stdout \&code;
     $stdout = tee_stdout \&code;
  
  The C<<< tee_stdout >>> function works just like C<<< tee >>> except only
  STDOUT is teed.  STDERR is not teed (output goes to STDERR as usual).
  
  =head2 tee_stderr
  
     ($stderr, @result) = tee_stderr \&code;
     $stderr = tee_stderr \&code;
  
  The C<<< tee_stderr >>> function works just like C<<< tee >>> except only
  STDERR is teed.  STDOUT is not teed (output goes to STDOUT as usual).
  
  =head2 tee_merged
  
     ($merged, @result) = tee_merged \&code;
     $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.
  
  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.  See the
  L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
  for test result by platform.
  
  =head2 PerlIO layers
  
  Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or
  ':crlf' when capturing (only for Perl 5.8.1+) .  Layers should be applied to
  STDOUT or STDERR I<before> the call to C<<< capture >>> or C<<< tee >>>.  This may not work
  for tied filehandles (see below).
  
  =head2 Modifying filehandles before capturing
  
  Generally speaking, you should do little or no manipulation of the standard IO
  filehandles prior to using Capture::Tiny.  In particular, closing, reopening,
  localizing or tying standard filehandles prior to capture may cause a variety of
  unexpected, undesirable andE<sol>or unreliable behaviors, as described below.
  Capture::Tiny does its best to compensate for these situations, but the
  results may not be what you desire.
  
  B<Closed filehandles>
  
  Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
  closed.  However, since they will 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
  close them again when the capture block finishes.
  
  Note that this reopening will happen even for STDIN or a filehandle not being
  captured to ensure that the filehandle used for capture is not opened to file
  descriptor 0, as this causes problems on various platforms.
  
  Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
  and also breaks tee() for undiagnosed reasons.  So don't do that.
  
  B<Localized filehandles>
  
  If code localizes any of Perl's standard filehandles before capturing, the capture
  will affect the localized filehandles and not the original ones.  External system
  calls are not affected by localizing a filehandle in Perl and will continue
  to send output to the original filehandles (which will thus not be captured).
  
  B<Scalar filehandles>
  
  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 filehandle for
  the duration of the C<<< capture >>> or C<<< tee >>> call and then, for C<<< tee >>>, send captured
  output to the output filehandle after the capture is complete.  (Requires Perl
  5.8)
  
  Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
  reference, but note that external processes will not be able to read from such
  a handle.  Capture::Tiny tries to ensure that external processes will read from
  the null device instead, but this is not guaranteed.
  
  B<Tied output filehandles>
  
  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 filehandle after
  the capture is complete.  (Requires Perl 5.8)
  
  Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
  STDOUT or STDERR filehandle.  Characters may appear as bytes.  If the tied filehandle
  is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
  appropriate layers like C<<< :utf8 >>> from the underlying filehandle and do the right
  thing.
  
  B<Tied input filehandle>
  
  Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
  requires Perl 5.8 and is not entirely predictable.  External processes
  will not be able to read from such a handle.
  
  Unless having STDIN tied is crucial, it may be safest to localize STDIN when
  capturing:
  
     my ($out, $err) = do { local *STDIN; capture { ... } };
  
  =head2 Modifying filehandles 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 UTF-8.  Perl 5.8.1 or later
  is recommended.
  
  =head2 Limited support for Perl 5.6
  
  Perl 5.6 predates PerlIO.  UTF-8 data may not be captured correctly.
  
  =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 SEE ALSO
  
  This module was, inspired by L<IO::CaptureOutput>, which provides
  similar functionality without the ability to tee output and with more
  complicated code and API.  L<IO::CaptureOutput> does not handle layers
  or most of the unusual cases described in the L</Limitations> section and
  I no longer recommend it.
  
  There are many other 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 metacpan
  
  =head1 SUPPORT
  
  =head2 Bugs / Feature Requests
  
  Please report any bugs or feature requests through the issue tracker
  at L<https://github.com/dagolden/Capture-Tiny/issues>.
  You will be notified automatically of any progress on your issue.
  
  =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<https://github.com/dagolden/Capture-Tiny>
  
    git clone https://github.com/dagolden/Capture-Tiny.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler
  
  =over 4
  
  =item *
  
  Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
  
  =item *
  
  David E. Wheeler <david@justatheory.com>
  
  =back
  
  =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
CAPTURE_TINY

$fatpacked{"Class/C3.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_C3';
  
  package Class::C3;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.25';
  
  our $C3_IN_CORE;
  our $C3_XS;
  
  BEGIN {
      if($] > 5.009_004) {
          $C3_IN_CORE = 1;
          require mro;
      }
      elsif($C3_XS or not defined $C3_XS) {
          my $error = do {
              local $@;
              eval { require Class::C3::XS };
              $@;
          };
  
          if ($error) {
              die $error if $error !~ /\blocate\b/;
  
              if ($C3_XS) {
                  require Carp;
                  Carp::croak( "XS explicitly requested but Class::C3::XS is not available" );
              }
  
              require Algorithm::C3;
              require Class::C3::next;
          }
          else {
              $C3_XS = 1;
          }
      }
  }
  
  # this is our global stash of both
  # MRO's and method dispatch tables
  # the structure basically looks like
  # this:
  #
  #   $MRO{$class} = {
  #      MRO => [ <class precedence 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 interrogate 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 overridden 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 algorithm
  
  =head1 SYNOPSIS
  
      # NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead!
      package ClassA;
      use Class::C3;
      sub hello { 'A::hello' }
  
      package ClassB;
      use base 'ClassA';
      use Class::C3;
  
      package ClassC;
      use base 'ClassA';
      use Class::C3;
  
      sub hello { 'C::hello' }
  
      package ClassD;
      use base ('ClassB', 'ClassC');
      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('ClassD'); # prints ClassD, ClassB, ClassC, ClassA
  
      print ClassD->hello(); # prints 'C::hello' instead of the standard p5 'A::hello'
  
      ClassD->can('hello')->();          # can() also works correctly
      UNIVERSAL::can('ClassD', '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 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 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 trivial, for more complex examples and a deeper explanation, 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;
  
  This is more clunky:
  
    package MyClass;
    use Class::C3;
  
  But hey, it's your choice, that's 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 initialize 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
  convenience. I apologize to anyone this causes problems for (although I would be very surprised 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 ambiguous, and generally not recommended anyway.
  However, its use in conjunction 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 recalculate 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 interrogating 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.  The optional module will be automatically installed for you if a C compiler is available, 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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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.24';
  
  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.24';
  
  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
  necessary, 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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_DUMPER_CONCISE';
  package Data::Dumper::Concise;
  
  use 5.006;
  
  $VERSION = '2.021';
  
  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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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 { DwarnL(@_); return wantarray ? @_ : $_[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(@_); return wantarray ? @_ : $_[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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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.113';
  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';
  
      croak "Exporter::Declare::Magic must be installed seperately for -magic to work"
          unless eval { require Exporter::Declare::Magic };
  
      warn "Exporter::Declare -magic is deprecated. Please use Exporter::Declare::Magic directly";
  
      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 _is_exporter_class {
      my ($name) = @_;
  
      return 0 unless $name;
  
      # This is to work around a bug in older versions of UNIVERSAL::can which
      # would issue a warning about $name->can() when $name was not a valid
      # package.
      # This will first verify that $name is a namespace, if not it will return false.
      # If the namespace defines 'export_meta' we know it is an exporter.
      # If there is no @ISA array in the namespace we simply return false,
      # otherwise we fall back to $name->can().
      {
          no strict 'refs';
          no warnings 'once';
          return 0 unless keys %{"$name\::"};
          return 1 if defined *{"$name\::export_meta"}{CODE};
          return 0 unless @{"$name\::ISA"};
      }
  
      return eval { $name->can('export_meta'); 1 };
  }
  
  sub _find_export_class {
      my $args = shift;
  
      return shift(@$args)
          if @$args && _is_exporter_class(@$args);
  
      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
  
  Please use L<Exporter::Declare::Magic> directly from now on.
  
  =head2 DEPRECATED USAGE OF 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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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);
              next if $data->{$item};
              $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 is_argument {
      my $self = shift;
      my ($name) = @_;
      return exists $self->arguments->{$name} ? 1 : 0;
  }
  
  sub is_option {
      my $self = shift;
      my ($name) = @_;
      return exists $self->options->{$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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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 arguments {
      my $self = shift;
      my $meta = $self->package->export_meta;
      return grep { $meta->is_argument($_) } keys %{$self->config};
  }
  
  sub options {
      my $self = shift;
      my $meta = $self->package->export_meta;
      return grep { $meta->is_option($_) } keys %{$self->config};
  }
  
  sub tags {
      my $self = shift;
      my $meta = $self->package->export_meta;
      return grep { $meta->is_tag($_) } keys %{$self->config};
  }
  
  sub _make_info {
      my $self = shift;
      my $config = $self->config;
      return { map { $_, $config->{$_} } @_ };
  }
  
  sub argument_info {
      my $self = shift;
      return $self->_make_info($self->arguments);
  }
  
  sub option_info {
      my $self = shift;
      return $self->_make_info($self->options);
  }
  
  sub tag_info {
      my $self = shift;
      my $all_tags = $self->package->export_meta->export_tags;
      return { map { $_, $all_tags->{$_} } $self->tags };
  }
  
  
  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 @names = $specs->arguments()
  
  =item @names = $specs->options()
  
  =item @names = $specs->tags()
  
  Get the argument, option, or tag names that were specified for the import.
  
  =item $hashref = $specs->argument_info()
  
  Get the arguments that were specified for the import. The key is the name of the
  argument and the value is what the user supplied during import.
  
  =item $hashref = $specs->option_info()
  
  Get the options that were specified for the import. The key is the name of the user 
  supplied option and the value will evaluate to true.
  
  =item $hashref = $specs->tag_info()
  
  Get the values associated with the tags used during import. The key is the name of the tag
  and the value is an array ref containing the values given to export_tag() for the associated
  name.
  
  =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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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.27203';
  
  @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 unless defined $self->{incr_mode};
  
          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 if $self->{incr_mode} != INCR_M_STR;
                  }
  
              } until ( length $self->{incr_text} >= $self->{incr_p} );
  
              $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 (substr( $text, $p - 2, 1 ) eq '\\' ) {
                  next;
              }
  
              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_STR and not $self->{incr_nest} );
      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 || '';
  }
  
  
  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.27202
  
  L<JSON::XS> 2.27 (~2.30) compatible.
  
  =head1 NOTE
  
  JSON::PP had been inculded in JSON distribution (CPAN module).
  It was a perl core module in Perl 5.14.
  
  =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 = JSON::PP->new
  
  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-2013 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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL';
  package Log::Contextual;
  $Log::Contextual::VERSION = '0.006002';
  # ABSTRACT: Simple logging interface with a contextual log
  
  use strict;
  use warnings;
  
  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';
  use B qw(svref_2object);
  
  sub stash_name {
     my ($coderef) = @_;
     ref $coderef or return;
     my $cv = B::svref_2object($coderef);
     $cv->isa('B::CV') or return;
     # bail out if GV is undefined
     $cv->GV->isa('B::SPECIAL') and return;
  
     return $cv->GV->STASH->NAME;
  }
  
  my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
  
  my @log = ((map "log_$_", @levels), (map "logS_$_", @levels));
  
  sub _maybe_export {
     my ($spec, $target, $name, $new_code) = @_;
  
     if (my $code = $target->can($name)) {
  
        # this will warn
        $spec->add_export("&$name", $new_code)
          unless (stash_name($code) eq __PACKAGE__);
     } else {
        $spec->add_export("&$name", $new_code)
     }
  }
  
  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 router {
     our $Router_Instance ||= do {
        require Log::Contextual::Router;
        Log::Contextual::Router->new
       }
  }
  
  sub default_import {
     my ($class) = shift;
  
     die 'Log::Contextual does not have a default import list';
  
     ()
  }
  
  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 before_import {
     my ($class, $importer, $spec) = @_;
     my $router      = $class->router;
     my $exports     = $spec->exports;
     my %router_args = (
        exporter  => $class,
        target    => $importer,
        arguments => $spec->argument_info
     );
  
     my @tags = $class->default_import($spec)
       if $spec->config->{default};
  
     for (@tags) {
        die "only tags are supported for defaults at this time"
          unless $_ =~ /^:(.*)$/;
  
        $spec->config->{$1} = 1;
     }
  
     $router->before_import(%router_args);
  
     if ($exports->{'&set_logger'}) {
        die ref($router) . " does not support set_logger()"
          unless $router->does('Log::Contextual::Role::Router::SetLogger');
  
        _maybe_export($spec, $importer, 'set_logger',
           sub { $router->set_logger(@_) },
        );
     }
  
     if ($exports->{'&with_logger'}) {
        die ref($router) . " does not support with_logger()"
          unless $router->does('Log::Contextual::Role::Router::WithLogger');
  
        _maybe_export($spec, $importer, 'with_logger',
           sub { $router->with_logger(@_) },
        );
     }
  
     my @levels = @{$class->arg_levels($spec->config->{levels})};
     for my $level (@levels) {
        if ($spec->config->{log} || $exports->{"&log_$level"}) {
           _maybe_export(
              $spec,
              $importer,
              "log_$level",
              sub (&@) {
                 my ($code, @args) = @_;
                 $router->handle_log_request(
                    exporter       => $class,
                    caller_package => scalar(caller),
                    caller_level   => 1,
                    message_level  => $level,
                    message_sub    => $code,
                    message_args   => \@args,
                 );
                 return @args;
              },
           );
        }
        if ($spec->config->{log} || $exports->{"&logS_$level"}) {
           _maybe_export(
              $spec,
              $importer,
              "logS_$level",
              sub (&@) {
                 my ($code, @args) = @_;
                 $router->handle_log_request(
                    exporter       => $class,
                    caller_package => scalar(caller),
                    caller_level   => 1,
                    message_level  => $level,
                    message_sub    => $code,
                    message_args   => \@args,
                 );
                 return $args[0];
              },
           );
        }
        if ($spec->config->{dlog} || $exports->{"&Dlog_$level"}) {
           _maybe_export(
              $spec,
              $importer,
              "Dlog_$level",
              sub (&@) {
                 my ($code, @args) = @_;
                 my $wrapped = sub {
                    local $_ = (@_ ? Data::Dumper::Concise::Dumper @_ : '()');
                    &$code;
                 };
                 $router->handle_log_request(
                    exporter       => $class,
                    caller_package => scalar(caller),
                    caller_level   => 1,
                    message_level  => $level,
                    message_sub    => $wrapped,
                    message_args   => \@args,
                 );
                 return @args;
              },
           );
        }
        if ($spec->config->{dlog} || $exports->{"&DlogS_$level"}) {
           _maybe_export(
              $spec,
              $importer,
              "DlogS_$level",
              sub (&$) {
                 my ($code, $ref) = @_;
                 my $wrapped = sub {
                    local $_ = Data::Dumper::Concise::Dumper($_[0]);
                    &$code;
                 };
                 $router->handle_log_request(
                    exporter       => $class,
                    caller_package => scalar(caller),
                    caller_level   => 1,
                    message_level  => $level,
                    message_sub    => $wrapped,
                    message_args   => [$ref],
                 );
                 return $ref;
              });
        }
     }
  }
  
  sub after_import {
     my ($class, $importer, $spec) = @_;
     my %router_args = (
        exporter  => $class,
        target    => $importer,
        arguments => $spec->argument_info
     );
     $class->router->after_import(%router_args);
  }
  
  for (qw(set with)) {
     no strict 'refs';
     my $sub = "${_}_logger";
     *{"Log::Contextual::$sub"} = sub {
        die "$sub is no longer a direct sub in Log::Contextual.  "
          . 'Note that this feature was never tested nor documented.  '
          . "Please fix your code to import $sub instead of trying to use it directly"
       }
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual - Simple logging interface with a contextual log
  
  =head1 VERSION
  
  version 0.006002
  
  =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 {
  
     my $minilogger = Log::Contextual::SimpleLogger->new({
       levels => [qw( trace debug )]
     });
  
     my @args = @_;
  
     with_logger $minilogger => sub {
       log_trace { 'foo entered' };
       my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @args;
       # ...
       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
  
  Major benefits:
  
  =over 2
  
  =item * Efficient
  
  The logging functions take blocks, so if a log level is disabled, the
  block will not run:
  
   # the following won't run if debug is off
   log_debug { "the new count in the database is " . $rs->count };
  
  Similarly, the C<D> prefixed methods only C<Dumper> the input if the level is
  enabled.
  
  =item * Handy
  
  The logging functions return their arguments, so you can stick them in
  the middle of expressions:
  
   for (log_debug { "downloading:\n" . join qq(\n), @_ } @urls) { ... }
  
  =item * Generic
  
  C<Log::Contextual> is an interface for all major loggers.  If you log through
  C<Log::Contextual> you will be able to swap underlying loggers later.
  
  =item * Powerful
  
  C<Log::Contextual> chooses which logger to use based on L<< user defined C<CodeRef>s|/LOGGER CODEREF >>.
  Normally you don't need to know this, but you can take advantage of it when you
  need to later
  
  =item * Scalable
  
  If you just want to add logging to your extremely basic application, start with
  L<Log::Contextual::SimpleLogger> and then as your needs grow you can switch to
  L<Log::Dispatchouli> or L<Log::Dispatch> or L<Log::Log4perl> or whatever else.
  
  =back
  
  This module is a simple interface to extensible logging.  It exists to
  abstract your logging interface so that logging is as painless as possible,
  while still allowing you to switch from one logger to another.
  
  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.)
  
  =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 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 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_default_logger { $_[1] || Log::Log4perl->get_logger }
   sub arg_levels { [qw(debug trace warn info error fatal custom_level)] }
   sub default_import { ':log' }
  
   # or maybe instead of default_logger
   sub arg_package_logger { $_[1] }
  
   # and almost definitely not this, which is only here for completeness
   sub arg_logger { $_[1] }
  
  Note the C<< $_[1] || >> in C<arg_default_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 -default_logger => $foo,
                              -levels => [qw(bar baz biff)];
  
  Your C<arg_default_logger> method will get C<$foo> and your C<arg_levels>
  will get C<[qw(bar baz biff)]>;
  
  Additionally, the C<default_import> method is what happens if a user tries to
  use your subclass with no arguments.  The default just dies, but if you'd like
  to change the default to import a tag merely return the tags you'd like to
  import.  So the following will all work:
  
   sub default_import { ':log' }
  
   sub default_import { ':dlog' }
  
   sub default_import { qw(:dlog :log ) }
  
  See L<Log::Contextual::Easy::Default> for an example of a subclass of
  C<Log::Contextual> that makes use of default import options.
  
  =head1 FUNCTIONS
  
  =head2 set_logger
  
   my $logger = WarnLogger->new;
   set_logger $logger;
  
  Arguments: L</LOGGER CODEREF>
  
  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: L</LOGGER CODEREF>, C<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>
  
  C<log_$level> functions all 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.
  
  Which functions are exported depends on what was passed to L</-levels>.  The
  default (no C<-levels> option passed) would export:
  
  =over 2
  
  =item log_trace
  
  =item log_debug
  
  =item log_info
  
  =item log_warn
  
  =item log_error
  
  =item log_fatal
  
  =back
  
  =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"
  
  Which functions are exported depends on what was passed to L</-levels>.  The
  default (no C<-levels> option passed) would export:
  
  =over 2
  
  =item Dlog_trace
  
  =item Dlog_debug
  
  =item Dlog_info
  
  =item Dlog_warn
  
  =item Dlog_error
  
  =item Dlog_fatal
  
  =back
  
  =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 CODEREF
  
  Anywhere a logger object can be passed, a coderef is accepted.  This is so
  that the user can use different logger objects based on runtime information.
  The logger coderef is passed the package of the caller the caller level the
  coderef needs to use if it wants more caller information.  The latter is in
  a hashref to allow for more options in the future.
  
  Here is a basic example of a logger that exploits C<caller> to reproduce the
  output of C<warn> with a logger:
  
   my @caller_info;
   my $var_log = Log::Contextual::SimpleLogger->new({
      levels  => [qw(trace debug info warn error fatal)],
      coderef => sub { chomp($_[0]); warn "$_[0] at $caller_info[1] line $caller_info[2].\n" }
   });
   my $warn_faker = sub {
      my ($package, $args) = @_;
      @caller_info = caller($args->{caller_level});
      $var_log
   };
   set_logger($warn_faker);
   log_debug { 'test' };
  
  The following is an example that uses the information passed to the logger
  coderef.  It sets the global logger to C<$l3>, the logger for the C<A1>
  package to C<$l1>, except the C<lol> method in C<A1> which uses the C<$l2>
  logger and lastly the logger for the C<A2> package to C<$l2>.
  
  Note that it increases the caller level as it dispatches based on where
  the caller of the log function, not the log function itself.
  
   my $complex_dispatcher = do {
  
      my $l1 = ...;
      my $l2 = ...;
      my $l3 = ...;
  
      my %registry = (
         -logger => $l3,
         A1 => {
            -logger => $l1,
            lol     => $l2,
         },
         A2 => { -logger => $l2 },
      );
  
      sub {
         my ( $package, $info ) = @_;
  
         my $logger = $registry{'-logger'};
         if (my $r = $registry{$package}) {
            $logger = $r->{'-logger'} if $r->{'-logger'};
            my (undef, undef, undef, $sub) = caller($info->{caller_level} + 1);
            $sub =~ s/^\Q$package\E:://g;
            $logger = $r->{$sub} if $r->{$sub};
         }
         return $logger;
      }
   };
  
   set_logger $complex_dispatcher;
  
  =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 LOG ROUTING
  
  In between the loggers and the log functions is a log router that is responsible for
  finding a logger to handle the log event and passing the log information to the
  logger. This relationship is described in the documentation for C<Log::Contextual::Role::Router>.
  
  C<Log::Contextual> and packages that extend it will by default share a router singleton that
  implements the with_logger() and set_logger() functions and also respects the -logger,
  -package_logger, and -default_logger import options with their associated default value
  functions. The router singleton is available as the return value of the router() function. Users
  of Log::Contextual may overload router() to return instances of custom log routers that
  could for example work with loggers that use a different interface.
  
  =head1 CONTRIBUTORS
  
  triddle - Tyler Riddle <t.riddle@shadowcat.co.uk>
  
  voj - Jakob Voß <voss@gbv.de>
  
  =head1 DESIGNER
  
  mst - Matt S. Trout <mst@shadowcat.co.uk>
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL

$fatpacked{"Log/Contextual/Easy/Default.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_EASY_DEFAULT';
  package Log::Contextual::Easy::Default;
  $Log::Contextual::Easy::Default::VERSION = '0.006002';
  # ABSTRACT: Import all logging methods with WarnLogger as default
  
  use strict;
  use warnings;
  
  use base 'Log::Contextual';
  
  sub arg_default_logger {
     if ($_[1]) {
        return $_[1];
     } else {
        require Log::Contextual::WarnLogger;
        my $package = uc(caller(3));
        $package =~ s/::/_/g;
        return Log::Contextual::WarnLogger->new({env_prefix => $package});
     }
  }
  
  sub default_import { qw(:dlog :log ) }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::Easy::Default - Import all logging methods with WarnLogger as default
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 SYNOPSIS
  
  In your module:
  
   package My::Module;
   use Log::Contextual::Easy::Default;
  
   log_debug { "your message" };
   Dlog_trace { $_ } @vars;
  
  In your program:
  
   use My::Module;
  
   # enable warnings
   $ENV{MY_MODULE_UPTO}="TRACE";
  
   # or use a specific logger with set_logger / with_logger
  
  =head1 DESCRIPTION
  
  By default, this module enables a L<Log::Contextual::WarnLogger>
  with C<env_prefix> based on the module's name that uses
  Log::Contextual::Easy. The logging levels are set to C<trace> C<debug>,
  C<info>, C<warn>, C<error>, and C<fatal> (in this order) and all
  logging functions (L<log_...|Log::Contextual/"log_$level">,
  L<logS_...|Log::Contextual/"logS_$level">,
  L<Dlog_...|Log::Contextual/"Dlog_$level">, and
  L<Dlog...|Log::Contextual/"DlogS_$level">) are exported.
  
  For what C<::Default> implies, see L<Log::Contextual/-default_logger>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<Log::Contextual::Easy::Package>
  
  =back
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_EASY_DEFAULT

$fatpacked{"Log/Contextual/Easy/Package.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_EASY_PACKAGE';
  package Log::Contextual::Easy::Package;
  $Log::Contextual::Easy::Package::VERSION = '0.006002';
  # ABSTRACT: Import all logging methods with WarnLogger as default package logger
  
  use strict;
  use warnings;
  
  use base 'Log::Contextual';
  
  sub arg_package_logger {
     if ($_[1]) {
        return $_[1];
     } else {
        require Log::Contextual::WarnLogger;
        my $package = uc(caller(3));
        $package =~ s/::/_/g;
        return Log::Contextual::WarnLogger->new({env_prefix => $package});
     }
  }
  
  sub default_import { qw(:dlog :log ) }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::Easy::Package - Import all logging methods with WarnLogger as default package logger
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 SYNOPSIS
  
  In your module:
  
   package My::Module;
   use Log::Contextual::Easy::Package;
  
   log_debug { "your message" };
   Dlog_trace { $_ } @vars;
  
  In your program:
  
   use My::Module;
  
   # enable warnings
   $ENV{MY_MODULE_UPTO}="TRACE";
  
   # or use a specific logger with set_logger / with_logger
  
  =head1 DESCRIPTION
  
  By default, this module enables a L<Log::Contextual::WarnLogger>
  with C<env_prefix> based on the module's name that uses
  Log::Contextual::Easy. The logging levels are set to C<trace> C<debug>,
  C<info>, C<warn>, C<error>, and C<fatal> (in this order) and all
  logging functions (L<log_...|Log::Contextual/"log_$level">,
  L<logS_...|Log::Contextual/"logS_$level">,
  L<Dlog_...|Log::Contextual/"Dlog_$level">, and
  L<Dlog...|Log::Contextual/"DlogS_$level">) are exported.
  
  For what C<::Package> implies, see L<Log::Contextual/-package_logger>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<Log::Contextual::Easy::Default>
  
  =back
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_EASY_PACKAGE

$fatpacked{"Log/Contextual/Role/Router.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROLE_ROUTER';
  package Log::Contextual::Role::Router;
  $Log::Contextual::Role::Router::VERSION = '0.006002';
  # ABSTRACT: Abstract interface between loggers and logging code blocks
  
  use Moo::Role;
  
  requires 'before_import';
  requires 'after_import';
  requires 'handle_log_request';
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::Role::Router - Abstract interface between loggers and logging code blocks
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 SYNOPSIS
  
    package MyApp::Log::Router;
  
    use Moo;
    use Log::Contextual::SimpleLogger;
  
    with 'Log::Contextual::Role::Router';
  
    has logger => (is => 'lazy');
  
    sub _build_logger {
       return Log::Contextual::SimpleLogger->new({ levels_upto => 'debug' });
    }
  
    sub before_import {
       my ($self, %export_info) = @_;
       my $exporter = $export_info{exporter};
       my $target = $export_info{target};
       print STDERR "Package '$target' will import from '$exporter'\n";
    }
  
    sub after_import {
       my ($self, %export_info) = @_;
       my $exporter = $export_info{exporter};
       my $target = $export_info{target};
       print STDERR "Package '$target' has imported from '$exporter'\n";
    }
  
    sub handle_log_request {
       my ($self, %message_info) = @_;
       my $log_code_block = $message_info{message_sub};
       my $args = $message_info{message_args};
       my $log_level_name = $message_info{message_level};
       my $logger = $self->logger;
       my $is_active = $logger->can("is_${log_level_name}");
  
       return unless defined $is_active && $logger->$is_active;
       my $log_message = $log_code_block->(@$args);
       $logger->$log_level_name($log_message);
    }
  
    package MyApp::Log::Contextual;
  
    use Moo;
    use MyApp::Log::Router;
  
    extends 'Log::Contextual';
  
    #This example router is a singleton
    sub router {
       our $Router ||= MyApp::Log::Router->new
    }
  
    package main;
  
    use strict;
    use warnings;
    use MyApp::Log::Contextual qw(:log);
  
    log_info { "Hello there" };
  
  =head1 DESCRIPTION
  
  Log::Contextual has three parts
  
  =over 4
  
  =item Export manager and logging method generator
  
  These tasks are handled by the C<Log::Contextual> package.
  
  =item Logger selection and invocation
  
  The logging functions generated and exported by Log::Contextual call a method
  on an instance of a log router object which is responsible for invoking any loggers
  that should get an opportunity to receive the log message. The C<Log::Contextual::Router>
  class implements the set_logger() and with_logger() functions as well as uses the
  arg_ prefixed functions to configure itself and provide the standard C<Log::Contextual>
  logger selection API.
  
  =item Log message formatting and output
  
  The logger objects themselves accept or reject a log message at a certain log
  level with a guard method per level. If the logger is going to accept the
  log message the router is then responsible for executing the log message code
  block and passing the generated message to the logging object's log method.
  
  =back
  
  =head1 METHODS
  
  =over 4
  
  =item before_import($self, %import_info)
  
  =item after_import($self,  %import_info)
  
  These two required methods are called with identical arguments at two different places
  during the import process. The before_import() method is invoked prior to the logging
  subroutines being exported into the target package and after_import() is called when the
  export is completed but before control returns to the package that imported the API.
  
  The arguments are passed as a hash with the following keys:
  
  =over 4
  
  =item exporter
  
  This is the name of the package that has been imported. It can also be 'Log::Contextual' itself. In
  the case of the synopsis the value for exporter would be 'MyApp::Log::Contextual'.
  
  =item target
  
  This is the package name that is importing the logging API. In the case of the synopsis the
  value would be 'main'.
  
  =item arguments
  
  This is a hash reference containing the configuration values that were provided for the import.
  The key is the name of the configuration item that was specified without the leading hyphen ('-').
  For instance if the logging API is imported as follows
  
    use Log::Contextual qw( :log ), -logger => Custom::Logger->new({ levels => [qw( debug )] });
  
  then $import_info{arguments}->{logger} would contain that instance of Custom::Logger.
  
  =back
  
  =item handle_log_request($self, %message_info)
  
  This method is called by C<Log::Contextual> when a log event happens. The arguments are passed
  as a hash with the following keys
  
  =over 4
  
  =item exporter
  
  This is the name of the package that created the logging methods used to generate the log event.
  
  =item caller_package
  
  This is the name of the package that the log event has happened inside of.
  
  =item caller_level
  
  This is an integer that contains the value to pass to caller() that will provide
  information about the location the log event was created at.
  
  =item log_level
  
  This is the name of the log level associated with the log event.
  
  =item message_sub
  
  This is the message generating code block associated with the log event passed as a subref. If
  the logger accepts the log request the router should execute the subref to create
  the log message and then pass the message as a string to the logger.
  
  =item message_args
  
  This is an array reference that contains the arguments given to the message generating code block.
  When invoking the message generator it will almost certainly be expecting these argument values
  as well.
  
  =back
  
  =back
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_ROLE_ROUTER

$fatpacked{"Log/Contextual/Role/Router/SetLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROLE_ROUTER_SETLOGGER';
  package Log::Contextual::Role::Router::SetLogger;
  $Log::Contextual::Role::Router::SetLogger::VERSION = '0.006002';
  use Moo::Role;
  
  requires 'set_logger';
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::Role::Router::SetLogger
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_ROLE_ROUTER_SETLOGGER

$fatpacked{"Log/Contextual/Role/Router/WithLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROLE_ROUTER_WITHLOGGER';
  package Log::Contextual::Role::Router::WithLogger;
  $Log::Contextual::Role::Router::WithLogger::VERSION = '0.006002';
  use Moo::Role;
  
  requires 'with_logger';
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::Role::Router::WithLogger
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_ROLE_ROUTER_WITHLOGGER

$fatpacked{"Log/Contextual/Router.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROUTER';
  package Log::Contextual::Router;
  $Log::Contextual::Router::VERSION = '0.006002';
  use Moo;
  use Scalar::Util 'blessed';
  
  with 'Log::Contextual::Role::Router',
    'Log::Contextual::Role::Router::SetLogger',
    'Log::Contextual::Role::Router::WithLogger';
  
  eval {
     require Log::Log4perl;
     die if $Log::Log4perl::VERSION < 1.29;
     Log::Log4perl->wrapper_register(__PACKAGE__)
  };
  
  has _default_logger => (
     is       => 'ro',
     default  => sub { {} },
     init_arg => undef,
  );
  
  has _package_logger => (
     is       => 'ro',
     default  => sub { {} },
     init_arg => undef,
  );
  
  has _get_logger => (
     is       => 'ro',
     default  => sub { {} },
     init_arg => undef,
  );
  
  sub before_import { }
  
  sub after_import {
     my ($self, %import_info) = @_;
     my $exporter = $import_info{exporter};
     my $target   = $import_info{target};
     my $config   = $import_info{arguments};
  
     if (my $l = $exporter->arg_logger($config->{logger})) {
        $self->set_logger($l);
     }
  
     if (my $l = $exporter->arg_package_logger($config->{package_logger})) {
        $self->_set_package_logger_for($target, $l);
     }
  
     if (my $l = $exporter->arg_default_logger($config->{default_logger})) {
        $self->_set_default_logger_for($target, $l);
     }
  }
  
  sub with_logger {
     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 }
          }
     }
     local $_[0]->_get_logger->{l} = $logger;
     $_[2]->();
  }
  
  sub set_logger {
     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 }
          }
     }
  
     warn 'set_logger (or -logger) called more than once!  This is a bad idea!'
       if $_[0]->_get_logger->{l};
     $_[0]->_get_logger->{l} = $logger;
  }
  
  sub _set_default_logger_for {
     my $logger = $_[2];
     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 }
          }
     }
     $_[0]->_default_logger->{$_[1]} = $logger
  }
  
  sub _set_package_logger_for {
     my $logger = $_[2];
     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 }
          }
     }
     $_[0]->_package_logger->{$_[1]} = $logger
  }
  
  sub get_loggers {
     my ($self, %info) = @_;
     my $package   = $info{caller_package};
     my $log_level = $info{message_level};
     my $logger =
       (     $_[0]->_package_logger->{$package}
          || $_[0]->_get_logger->{l}
          || $_[0]->_default_logger->{$package}
          || die
          q( no logger set!  you can't try to log something without a logger! ));
  
     $info{caller_level}++;
     $logger = $logger->($package, \%info);
  
     return $logger if $logger ->${\"is_${log_level}"};
     return ();
  }
  
  sub handle_log_request {
     my ($self, %message_info) = @_;
     my $generator = $message_info{message_sub};
     my $args      = $message_info{message_args};
     my $log_level = $message_info{message_level};
  
     $message_info{caller_level}++;
  
     foreach my $logger ($self->get_loggers(%message_info)) {
        $logger->$log_level($generator->(@$args));
     }
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::Router
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_ROUTER

$fatpacked{"Log/Contextual/SimpleLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_SIMPLELOGGER';
  package Log::Contextual::SimpleLogger;
  $Log::Contextual::SimpleLogger::VERSION = '0.006002';
  # ABSTRACT: Super simple logger made for playing with Log::Contextual
  
  
  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__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::SimpleLogger - Super simple logger made for playing with Log::Contextual
  
  =head1 VERSION
  
  version 0.006002
  
  =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
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_SIMPLELOGGER

$fatpacked{"Log/Contextual/TeeLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_TEELOGGER';
  package Log::Contextual::TeeLogger;
  $Log::Contextual::TeeLogger::VERSION = '0.006002';
  # ABSTRACT: Output to more than one logger
  
  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__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::TeeLogger - Output to more than one logger
  
  =head1 VERSION
  
  version 0.006002
  
  =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
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_TEELOGGER

$fatpacked{"Log/Contextual/WarnLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_WARNLOGGER';
  package Log::Contextual::WarnLogger;
  $Log::Contextual::WarnLogger::VERSION = '0.006002';
  # ABSTRACT: logger for libraries using Log::Contextual
  
  use strict;
  use warnings;
  
  use Carp 'croak';
  
  my @default_levels = qw( trace debug info warn error fatal );
  
  # generate subs to handle the default levels
  # anything else will have to be handled by AUTOLOAD at runtime
  {
     for my $level (@default_levels) {
  
        no strict 'refs';
  
        my $is_name = "is_$level";
        *{$level} = sub {
           my $self = shift;
  
           $self->_log($level, @_)
             if $self->$is_name;
        };
  
        *{$is_name} = sub {
           my $self = shift;
           return 1 if $ENV{$self->{env_prefix} . '_' . uc $level};
           my $upto = $ENV{$self->{env_prefix} . '_UPTO'};
           return unless $upto;
           $upto = lc $upto;
  
           return $self->{level_num}{$level} >= $self->{level_num}{$upto};
        };
     }
  }
  
  our $AUTOLOAD;
  
  sub AUTOLOAD {
     my $self = $_[0];
  
     (my $name = our $AUTOLOAD) =~ s/.*:://;
     return if $name eq 'DESTROY';
  
     # extract the log level from the sub name
     my ($is, $level) = $name =~ m/^(is_)?(.+)$/;
     my $is_name = "is_$level";
  
     no strict 'refs';
     *{$level} = sub {
        my $self = shift;
  
        $self->_log($level, @_)
          if $self->$is_name;
     };
  
     *{$is_name} = sub {
        my $self = shift;
  
        my $prefix_field = $self->{env_prefix} . '_' . uc $level;
        return 1 if $ENV{$prefix_field};
  
        # don't log if the variable specifically says not to
        return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field};
  
        my $upto_field = $self->{env_prefix} . '_UPTO';
        my $upto       = $ENV{$upto_field};
  
        if ($upto) {
           $upto = lc $upto;
  
           croak "Unrecognized log level '$upto' in \$ENV{$upto_field}"
             if not defined $self->{level_num}{$upto};
  
           return $self->{level_num}{$level} >= $self->{level_num}{$upto};
        }
  
        # if we don't recognize this level and nothing says otherwise, log!
        return 1 if not $self->{custom_levels};
     };
     goto &$AUTOLOAD;
  }
  
  sub new {
     my ($class, $args) = @_;
  
     my $levels = $args->{levels};
     croak 'invalid levels specification: must be non-empty arrayref'
       if defined $levels and (ref $levels ne 'ARRAY' or !@$levels);
  
     my $custom_levels = defined $levels;
     $levels ||= [@default_levels];
  
     my %level_num;
     @level_num{@$levels} = (0 .. $#{$levels});
  
     my $self = bless {
        levels        => $levels,
        level_num     => \%level_num,
        custom_levels => $custom_levels,
     }, $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__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Log::Contextual::WarnLogger - logger for libraries using Log::Contextual
  
  =head1 VERSION
  
  version 0.006002
  
  =head1 SYNOPSIS
  
   package My::Package;
   use Log::Contextual::WarnLogger;
   use Log::Contextual qw( :log ),
     -default_logger => Log::Contextual::WarnLogger->new({
        env_prefix => 'MY_PACKAGE',
        levels => [ qw(debug info notice warning error critical alert emergency) ],
     });
  
   # 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, levels => List ] $conf >>
  
   my $l = Log::Contextual::WarnLogger->new({ env_prefix => 'BAR' });
  
  or:
  
   my $l = Log::Contextual::WarnLogger->new({
     env_prefix => 'BAR',
     levels => [ 'level1', 'level2' ],
   });
  
  Creates a new logger object where C<env_prefix> defines what the prefix is for
  the environment variables that will be checked for the log levels.
  
  The log levels may be customized, but if not defined, these are used:
  
  =over 4
  
  =item trace
  
  =item debug
  
  =item info
  
  =item warn
  
  =item error
  
  =item fatal
  
  =back
  
  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!' );
  
  If different levels are specified, appropriate functions named for your custom
  levels work as you expect.
  
  =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;
  
  If different levels are specified, appropriate is_$level functions work as you
  would expect.
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
LOG_CONTEXTUAL_WARNLOGGER

$fatpacked{"MRO/Compat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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.12';
  
  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 PPP;      use base qw/Exporter/;
     package X;        use base qw/PPP/;
     package Y;        use base qw/PPP/;
     package Z;        use base qw/PPP/;
  
     package FooClass; use base qw/X Y Z/;
  
     package main;
     use MRO::Compat;
     my $linear = mro::get_linear_isa('FooClass');
     print join(q{, }, @$linear);
  
     # Prints: FooClass, X, PPP, Exporter, 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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_ACCESSOR';
  package Method::Generate::Accessor;
  
  use Moo::_strictures;
  use Moo::_Utils;
  use Moo::Object ();
  our @ISA = qw(Moo::Object);
  use Sub::Quote qw(quote_sub quoted_from_sub quotify);
  use Scalar::Util 'blessed';
  use overload ();
  use Module::Runtime qw(use_module);
  BEGIN {
    our $CAN_HAZ_XS =
      !$ENV{MOO_XS_DISABLE}
        &&
      _maybe_load_module('Class::XSAccessor')
        &&
      (eval { Class::XSAccessor->VERSION('1.07') })
    ;
    our $CAN_HAZ_XS_PRED =
      $CAN_HAZ_XS &&
      (eval { Class::XSAccessor->VERSION('1.17') })
    ;
  }
  
  my $module_name_only = qr/\A$Module::Runtime::module_name_rx\z/;
  
  sub _die_overwrite
  {
    my ($pkg, $method, $type) = @_;
    die "You cannot overwrite a locally defined method ($method) with "
      . ( $type || 'an accessor' );
  }
  
  sub generate_method {
    my ($self, $into, $name, $spec, $quote_opts) = @_;
    $spec->{allow_overwrite}++ if $name =~ s/^\+//;
    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}
        or ( $spec->{reader} and $spec->{writer} );
    } elsif ($is eq 'lazy') {
      $spec->{reader} = $name unless exists $spec->{reader};
      $spec->{lazy} = 1;
      $spec->{builder} ||= '_build_'.$name unless exists $spec->{default};
    } elsif ($is eq 'rwp') {
      $spec->{reader} = $name unless exists $spec->{reader};
      $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
    } elsif ($is ne 'bare') {
      die "Unknown is ${is}";
    }
    if (exists $spec->{builder}) {
      if(ref $spec->{builder}) {
        $self->_validate_codulatable('builder', $spec->{builder},
          "$into->$name", 'or a method name');
        $spec->{builder_sub} = $spec->{builder};
        $spec->{builder} = 1;
      }
      $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
      die "Invalid builder for $into->$name - not a valid method name"
        if $spec->{builder} !~ $module_name_only;
    }
    if (($spec->{predicate}||0) eq 1) {
      $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
    }
    if (($spec->{clearer}||0) eq 1) {
      $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
    }
    if (($spec->{trigger}||0) eq 1) {
      $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
    }
    if (($spec->{coerce}||0) eq 1) {
      my $isa = $spec->{isa};
      if (blessed $isa and $isa->can('coercion')) {
        $spec->{coerce} = $isa->coercion;
      } elsif (blessed $isa and $isa->can('coerce')) {
        $spec->{coerce} = sub { $isa->coerce(@_) };
      } else {
        die "Invalid coercion for $into->$name - no appropriate type constraint";
      }
    }
  
    foreach my $setting (qw( isa coerce )) {
      next if !exists $spec->{$setting};
      $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
    }
  
    if (exists $spec->{default}) {
      if (ref $spec->{default}) {
        $self->_validate_codulatable('default', $spec->{default}, "$into->$name",
          'or a non-ref');
      }
    }
  
    if (exists $spec->{moosify}) {
      if (ref $spec->{moosify} ne 'ARRAY') {
        $spec->{moosify} = [$spec->{moosify}];
      }
  
      foreach my $spec (@{$spec->{moosify}}) {
        $self->_validate_codulatable('moosify', $spec, "$into->$name");
      }
    }
  
    my %methods;
    if (my $reader = $spec->{reader}) {
      _die_overwrite($into, $reader, 'a reader')
        if !$spec->{allow_overwrite} && defined &{"${into}::${reader}"};
      if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
        $methods{$reader} = $self->_generate_xs(
          getters => $into, $reader, $name, $spec
        );
      } 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}) {
      _die_overwrite($into, $accessor, 'an accessor')
        if !$spec->{allow_overwrite} && defined &{"${into}::${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, $spec
        );
      } else {
        $self->{captures} = {};
        $methods{$accessor} =
          quote_sub "${into}::${accessor}"
            => $self->_generate_getset($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $writer = $spec->{writer}) {
      _die_overwrite($into, $writer, 'a writer')
        if !$spec->{allow_overwrite} && defined &{"${into}::${writer}"};
      if (
        our $CAN_HAZ_XS
        && $self->is_simple_set($name, $spec)
      ) {
        $methods{$writer} = $self->_generate_xs(
          setters => $into, $writer, $name, $spec
        );
      } else {
        $self->{captures} = {};
        $methods{$writer} =
          quote_sub "${into}::${writer}"
            => $self->_generate_set($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $pred = $spec->{predicate}) {
      _die_overwrite($into, $pred, 'a predicate')
        if !$spec->{allow_overwrite} && defined &{"${into}::${pred}"};
      if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) {
        $methods{$pred} = $self->_generate_xs(
          exists_predicates => $into, $pred, $name, $spec
        );
      } else {
        $methods{$pred} =
          quote_sub "${into}::${pred}" =>
            '    '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
          ;
      }
    }
    if (my $pred = $spec->{builder_sub}) {
      _install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} );
    }
    if (my $cl = $spec->{clearer}) {
      _die_overwrite($into, $cl, 'a clearer')
        if !$spec->{allow_overwrite} && defined &{"${into}::${cl}"};
      $methods{$cl} =
        quote_sub "${into}::${cl}" =>
          $self->_generate_simple_clear('$_[0]', $name, $spec)."\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 [ $_ => $_ ], use_module('Moo::Role')->methods_provided_by(use_module($hspec))
        } else {
          die "You gave me a handles of ${hspec} and I have no idea why";
        }
      };
      foreach my $delegation_spec (@specs) {
        my ($proxy, $target, @args) = @$delegation_spec;
        _die_overwrite($into, $proxy, 'a delegation')
          if !$spec->{allow_overwrite} && defined &{"${into}::${proxy}"};
        $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}" =>
          $self->_generate_asserter($name, $spec),
          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 (exists $spec->{default} or $spec->{builder}));
  }
  
  sub is_simple_set {
    my ($self, $name, $spec) = @_;
    !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
  }
  
  sub has_default {
    my ($self, $name, $spec) = @_;
    $spec->{builder} or exists $spec->{default} or (($spec->{is}||'') eq 'lazy');
  }
  
  sub has_eager_default {
    my ($self, $name, $spec) = @_;
    (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
  }
  
  sub _generate_get {
    my ($self, $name, $spec) = @_;
    my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
    if ($self->is_simple_get($name, $spec)) {
      $simple;
    } else {
      $self->_generate_use_default(
        '$_[0]', $name, $spec,
        $self->_generate_simple_has('$_[0]', $name, $spec),
      );
    }
  }
  
  sub generate_simple_has {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_simple_has(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_simple_has {
    my ($self, $me, $name) = @_;
    "exists ${me}->{${\quotify $name}}";
  }
  
  sub _generate_simple_clear {
    my ($self, $me, $name) = @_;
    "    delete ${me}->{${\quotify $name}}\n"
  }
  
  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 = shift;
    $self->{captures} = {};
    my $code = $self->_generate_use_default(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_use_default {
    my ($self, $me, $name, $spec, $test) = @_;
    my $get_value = $self->_generate_get_default($me, $name, $spec);
    if ($spec->{coerce}) {
      $get_value = $self->_generate_coerce(
        $name, $get_value,
        $spec->{coerce}
      )
    }
    $test." ? \n"
    .$self->_generate_simple_get($me, $name, $spec)."\n:"
    .($spec->{isa} ?
         "    do {\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"
    );
  }
  
  sub _generate_get_default {
    my ($self, $me, $name, $spec) = @_;
    if (exists $spec->{default}) {
      ref $spec->{default}
        ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
      : quotify $spec->{default};
    }
    else {
      "${me}->${\$spec->{builder}}"
    }
  }
  
  sub generate_simple_get {
    my ($self, @args) = @_;
    $self->{captures} = {};
    my $code = $self->_generate_simple_get(@args);
    ($code, delete $self->{captures});
  }
  
  sub _generate_simple_get {
    my ($self, $me, $name) = @_;
    my $name_str = quotify $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 $value_store = '$_[0]';
      my $code;
      if ($coerce) {
        $value_store = '$value';
        $code = "do { my (\$self, \$value) = \@_;\n"
          ."        \$value = "
          .$self->_generate_coerce($name, $value_store, $coerce).";\n";
      }
      else {
        $code = "do { my \$self = shift;\n";
      }
      if ($isa_check) {
        $code .=
          "        ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n";
      }
      my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store);
      if ($trigger) {
        my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger);
        $code .=
          "        ".$simple.";\n        ".$fire.";\n"
          ."        $value_store;\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 _attr_desc {
    my ($name, $init_arg) = @_;
    return quotify($name) if !defined($init_arg) or $init_arg eq $name;
    return quotify($name).' (constructor argument: '.quotify($init_arg).')';
  }
  
  sub _generate_coerce {
    my ($self, $name, $value, $coerce, $init_arg) = @_;
    $self->_wrap_attr_exception(
      $name,
      "coercion",
      $init_arg,
      $self->_generate_call_code($name, 'coerce', "${value}", $coerce),
      1,
    );
  }
  
  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 _wrap_attr_exception {
    my ($self, $name, $step, $arg, $code, $want_return) = @_;
    my $prefix = quotify("${step} for "._attr_desc($name, $arg).' failed: ');
    "do {\n"
    .'  local $Method::Generate::Accessor::CurrentAttribute = {'."\n"
    .'    init_arg => '.quotify($arg).",\n"
    .'    name     => '.quotify($name).",\n"
    .'    step     => '.quotify($step).",\n"
    ."  };\n"
    .($want_return ? '  my $_return;'."\n" : '')
    .'  my $_error;'."\n"
    ."  {\n"
    .'    my $_old_error = $@;'."\n"
    ."    if (!eval {\n"
    .'      $@ = $_old_error;'."\n"
    .($want_return ? '      $_return ='."\n" : '')
    .'      '.$code.";\n"
    ."      1;\n"
    ."    }) {\n"
    .'      $_error = $@;'."\n"
    .'      if (!ref $_error) {'."\n"
    .'        $_error = '.$prefix.'.$_error;'."\n"
    ."      }\n"
    ."    }\n"
    .'    $@ = $_old_error;'."\n"
    ."  }\n"
    .'  die $_error if $_error;'."\n"
    .($want_return ? '  $_return;'."\n" : '')
    ."}\n"
  }
  
  sub _generate_isa_check {
    my ($self, $name, $value, $check, $init_arg) = @_;
    $self->_wrap_attr_exception(
      $name,
      "isa check",
      $init_arg,
      $self->_generate_call_code($name, 'isa_check', $value, $check)
    );
  }
  
  sub _generate_call_code {
    my ($self, $name, $type, $values, $sub) = @_;
    $sub = \&{$sub} if blessed($sub);  # coderef if blessed
    if (my $quoted = quoted_from_sub($sub)) {
      my $local = 1;
      if ($values eq '@_' || $values eq '$_[0]') {
        $local = 0;
        $values = '@_';
      }
      my $code = $quoted->[1];
      if (my $captures = $quoted->[2]) {
        my $cap_name = qq{\$${type}_captures_for_}.$self->_sanitize_name($name);
        $self->{captures}->{$cap_name} = \$captures;
        Sub::Quote::inlinify($code, $values,
          Sub::Quote::capture_unroll($cap_name, $captures, 6), $local);
      } else {
        Sub::Quote::inlinify($code, $values, undef, $local);
      }
    } else {
      my $cap_name = qq{\$${type}_for_}.$self->_sanitize_name($name);
      $self->{captures}->{$cap_name} = \$sub;
      "${cap_name}->(${values})";
    }
  }
  
  sub _sanitize_name {
    my ($self, $name) = @_;
    $name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
    $name;
  }
  
  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, $init_arg) = @_;
    if ($self->has_eager_default($name, $spec)) {
      my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
      my $get_default = $self->_generate_get_default(
                          '$new', $name, $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, $get_value,
          $spec->{coerce}, $init_arg
        )
      }
      ($spec->{isa}
        ? "    {\n      my \$value = ".$get_value.";\n      "
          .$self->_generate_isa_check(
            $name, '$value', $spec->{isa}, $init_arg
          ).";\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),
            $spec->{trigger}
          )." if ${test};\n"
        : ''
      );
    } else {
      "    if (${test}) {\n"
        .($spec->{coerce}
          ? "      $source = "
            .$self->_generate_coerce(
              $name, $source,
              $spec->{coerce}, $init_arg
            ).";\n"
          : ""
        )
        .($spec->{isa}
          ? "      "
            .$self->_generate_isa_check(
              $name, $source, $spec->{isa}, $init_arg
            ).";\n"
          : ""
        )
        ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
        .($spec->{trigger}
          ? "      "
            .$self->_generate_trigger(
              $name, $me, $self->_generate_simple_get($me, $name, $spec),
              $spec->{trigger}
            ).";\n"
          : ""
        )
        ."    }\n";
    }
  }
  
  sub _generate_core_set {
    my ($self, $me, $name, $spec, $value) = @_;
    my $name_str = quotify $name;
    "${me}->{${name_str}} = ${value}";
  }
  
  sub _generate_simple_set {
    my ($self, $me, $name, $spec, $value) = @_;
    my $name_str = quotify $name;
    my $simple = $self->_generate_core_set($me, $name, $spec, $value);
  
    if ($spec->{weak_ref}) {
      require Scalar::Util;
      my $get = $self->_generate_simple_get($me, $name, $spec);
  
      # Perl < 5.8.3 can't weaken refs to readonly vars
      # (e.g. string constants). This *can* be solved by:
      #
      # &Internals::SvREADONLY($foo, 0);
      # Scalar::Util::weaken($foo);
      # &Internals::SvREADONLY($foo, 1);
      #
      # but requires Internal functions and is just too damn crazy
      # so simply throw a better exception
      my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }";
      Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
        eval { Scalar::Util::weaken($simple); 1 }
          ? do { no warnings 'void'; $get }
          : do {
            if( \$@ =~ /Modification of a read-only value attempted/) {
              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_asserter {
    my ($self, $name, $spec) = @_;
  
    "do {\n"
     ."  my \$val = ".$self->_generate_get($name, $spec).";\n"
     ."  unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n"
     .qq!    die "Attempted to access '${name}' but it is not set";\n!
     ."  }\n"
     ."  \$val;\n"
     ."}\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 quotify
        # 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 },
      replace => 1,
    );
    $into->can($name);
  }
  
  sub default_construction_string { '{}' }
  
  sub _validate_codulatable {
    my ($self, $setting, $value, $into, $appended) = @_;
    my $invalid = "Invalid $setting '" . overload::StrVal($value)
      . "' for $into not a coderef";
    $invalid .= " $appended" if $appended;
  
    unless (ref $value and (ref $value eq 'CODE' or blessed($value))) {
      die "$invalid or code-convertible object";
    }
  
    unless (eval { \&$value }) {
      die "$invalid and could not be converted to a coderef: $@";
    }
  
    1;
  }
  
  1;
METHOD_GENERATE_ACCESSOR

$fatpacked{"Method/Generate/BuildAll.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_BUILDALL';
  package Method::Generate::BuildAll;
  
  use Moo::_strictures;
  use Moo::Object ();
  our @ISA = qw(Moo::Object);
  use Sub::Quote qw(quote_sub quotify);
  use Moo::_Utils;
  
  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 '.quotify($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 @{mro::get_linear_isa($into)};
    '    unless (('.$args.')[0]->{__no_BUILD__}) {'."\n"
    .join('', map qq{      ${me}->${_}(${args});\n}, @builds)
    ."   }\n";
  }
  
  1;
METHOD_GENERATE_BUILDALL

$fatpacked{"Method/Generate/Constructor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_CONSTRUCTOR';
  package Method::Generate::Constructor;
  
  use Moo::_strictures;
  use Sub::Quote qw(quote_sub unquote_sub quotify);
  use Sub::Defer;
  use Moo::_Utils qw(_getstash _getglob);
  use Moo;
  
  sub register_attribute_specs {
    my ($self, @new_specs) = @_;
    $self->assert_constructor;
    my $specs = $self->{attribute_specs}||={};
    while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
      if ($name =~ s/^\+//) {
        die "has '+${name}' given but no ${name} attribute already exists"
          unless my $old_spec = $specs->{$name};
        foreach my $key (keys %$old_spec) {
          if (!exists $new_spec->{$key}) {
            $new_spec->{$key} = $old_spec->{$key}
              unless $key eq 'handles';
          }
          elsif ($key eq 'moosify') {
            $new_spec->{$key} = [
              map { ref $_ eq 'ARRAY' ? @$_ : $_ }
                ($old_spec->{$key}, $new_spec->{$key})
            ];
          }
        }
      }
      if ($new_spec->{required}
        && !(
          $self->accessor_generator->has_default($name, $new_spec)
          || !exists $new_spec->{init_arg}
          || defined $new_spec->{init_arg}
        )
      ) {
        die "You cannot have a required attribute (${name})"
          . " without a default, builder, or an init_arg";
      }
      $new_spec->{index} = scalar keys %$specs
        unless defined $new_spec->{index};
      $specs->{$name} = $new_spec;
    }
    $self;
  }
  
  sub all_attribute_specs {
    $_[0]->{attribute_specs}
  }
  
  sub accessor_generator {
    $_[0]->{accessor_generator}
  }
  
  sub construction_string {
    my ($self) = @_;
    $self->{construction_string}
      ||= $self->_build_construction_string;
  }
  
  sub buildall_generator {
    require Method::Generate::BuildAll;
    Method::Generate::BuildAll->new;
  }
  
  sub _build_construction_string {
    my ($self) = @_;
    my $builder = $self->{construction_builder};
    $builder ? $self->$builder
      : 'bless('
      .$self->accessor_generator->default_construction_string
      .', $class);'
  }
  
  sub install_delayed {
    my ($self) = @_;
    $self->assert_constructor;
    my $package = $self->{package};
    my (undef, @isa) = @{mro::get_linear_isa($package)};
    my $isa = join ',', @isa;
    $self->{deferred_constructor} = defer_sub "${package}::new" => sub {
      my (undef, @new_isa) = @{mro::get_linear_isa($package)};
      if (join(',', @new_isa) ne $isa) {
        my ($expected_new) = grep { *{_getglob($_.'::new')}{CODE} } @isa;
        my ($found_new) = grep { *{_getglob($_.'::new')}{CODE} } @new_isa;
        if (($found_new||'') ne ($expected_new||'')) {
          $found_new ||= 'none';
          $expected_new ||= 'none';
          die "Expected parent constructor of $package expected to be"
          . " $expected_new, but found $found_new: changing the inheritance"
          . " chain (\@ISA) at runtime is unsupported";
        }
      }
      unquote_sub $self->generate_method(
        $package, 'new', $self->{attribute_specs}, { no_install => 1 }
      )
    };
    $self;
  }
  
  sub current_constructor {
    my ($self, $package) = @_;
    return *{_getglob("${package}::new")}{CODE};
  }
  
  sub assert_constructor {
    my ($self) = @_;
    my $package = $self->{package} or return 1;
    my $current = $self->current_constructor($package)
      or return 1;
    my $deferred = $self->{deferred_constructor}
      or die "Unknown constructor for $package already exists";
    return 1
      if $deferred == $current;
    my $current_deferred = (Sub::Defer::defer_info($current)||[])->[3];
    if ($current_deferred && $current_deferred == $deferred) {
      die "Constructor for $package has been inlined and cannot be updated";
    }
    die "Constructor for $package has been replaced with an unknown sub";
  }
  
  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')) {
      $body .= $self->buildall_generator->buildall_body_for(
        $into, '$new', '$args'
      );
    }
    $body .= '    return $new;'."\n";
    if ($into->can('DEMOLISH')) {
      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_handler}) {
      '    if ($class ne '.quotify($into).') {'."\n".
      $gen.
      '    }'."\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"
    .q{    die "BUILDARGS did not return a hashref" unless ref($args) eq 'HASH';}
    ."\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 $ag = $self->accessor_generator;
    my %test;
    NAME: foreach my $name (sort keys %$spec) {
      my $attr_spec = $spec->{$name};
      next NAME unless defined($attr_spec->{init_arg})
                         or $ag->has_eager_default($name, $attr_spec);
      $test{$name} = $attr_spec->{init_arg};
    }
    join '', map {
      my $arg_key = quotify($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, $test{$_},
      ));
    } sort keys %test;
  }
  
  sub _check_required {
    my ($self, $spec) = @_;
    my @required_init =
      map $spec->{$_}{init_arg},
        grep {
          my %s = %{$spec->{$_}}; # ignore required if default or builder set
          $s{required} and not($s{builder} or exists $s{default})
        } sort keys %$spec;
    return '' unless @required_init;
    '    if (my @missing = grep !exists $args->{$_}, '
      .join(', ', map quotify($_), @required_init).') {'."\n"
      .q{      die "Missing required arguments: ".join(', ', sort @missing);}."\n"
      ."    }\n";
  }
  
  # bootstrap our own constructor
  sub new {
    my $class = shift;
    delete _getstash(__PACKAGE__)->{new};
    bless $class->BUILDARGS(@_), $class;
  }
  Moo->_constructor_maker_for(__PACKAGE__)
  ->register_attribute_specs(
    attribute_specs => {
      is => 'ro',
      reader => 'all_attribute_specs',
    },
    accessor_generator => { is => 'ro' },
    construction_string => { is => 'lazy' },
    construction_builder => { is => 'bare' },
    subconstructor_handler => { is => 'ro' },
    package => { is => 'bare' },
  );
  
  1;
METHOD_GENERATE_CONSTRUCTOR

$fatpacked{"Method/Generate/DemolishAll.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_DEMOLISHALL';
  package Method::Generate::DemolishAll;
  
  use Moo::_strictures;
  use Moo::Object ();
  our @ISA = qw(Moo::Object);
  use Sub::Quote qw(quote_sub quotify);
  use Moo::_Utils;
  
  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 Devel::GlobalDestruction;
        eval {
          $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction);
        };
        $@;
      };
  
      # fatal warnings+die in DESTROY = bad times (perl rt#123398)
      no warnings FATAL => 'all';
      use warnings 'all';
      die $e if $e; # rethrow
    !;
  }
  
  sub demolishall_body_for {
    my ($self, $into, $me, $args) = @_;
    my @demolishers =
      grep *{_getglob($_)}{CODE},
      map "${_}::DEMOLISH",
      @{mro::get_linear_isa($into)};
    join '', map qq{    ${me}->${_}(${args});\n}, @demolishers;
  }
  
  sub _handle_subdemolish {
    my ($self, $into) = @_;
    '    if (ref($_[0]) ne '.quotify($into).') {'."\n".
    '      return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
    '    }'."\n";
  }
  
  1;
METHOD_GENERATE_DEMOLISHALL

$fatpacked{"Method/Inliner.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_INLINER';
  package Method::Inliner;
  
  use Moo::_strictures;
  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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO';
  package Moo;
  
  use Moo::_strictures;
  use Moo::_Utils;
  
  our $VERSION = '2.000002';
  $VERSION = eval $VERSION;
  
  require Moo::sification;
  Moo::sification->import;
  
  our %MAKERS;
  
  sub _install_tracked {
    my ($target, $name, $code) = @_;
    $MAKERS{$target}{exports}{$name} = $code;
    _install_coderef "${target}::${name}" => "Moo::${name}" => $code;
  }
  
  sub import {
    my $target = caller;
    my $class = shift;
    _set_loaded(caller);
  
    strict->import;
    warnings->import;
  
    if ($INC{'Role/Tiny.pm'} and Role::Tiny->is_role($target)) {
      die "Cannot import Moo into a role";
    }
    $MAKERS{$target} ||= {};
    _install_tracked $target => extends => sub {
      $class->_set_superclasses($target, @_);
      $class->_maybe_reset_handlemoose($target);
      return;
    };
    _install_tracked $target => with => sub {
      require Moo::Role;
      Moo::Role->apply_roles_to_package($target, @_);
      $class->_maybe_reset_handlemoose($target);
    };
    _install_tracked $target => has => sub {
      my $name_proto = shift;
      my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
      if (@_ % 2 != 0) {
        require Carp;
        Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
          . " attribute(s): even number of arguments expected, got " . scalar @_)
      }
      my %spec = @_;
      foreach my $name (@name_proto) {
        # Note that when multiple attributes specified, each attribute
        # needs a separate \%specs hashref
        my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
        $class->_constructor_maker_for($target)
              ->register_attribute_specs($name, $spec_ref);
        $class->_accessor_maker_for($target)
              ->generate_method($target, $name, $spec_ref);
        $class->_maybe_reset_handlemoose($target);
      }
      return;
    };
    foreach my $type (qw(before after around)) {
      _install_tracked $target => $type => sub {
        require Class::Method::Modifiers;
        _install_modifier($target, $type, @_);
        return;
      };
    }
    return if $MAKERS{$target}{is_class}; # already exported into this package
    my $stash = _getstash($target);
    my @not_methods = map { *$_{CODE}||() } grep !ref($_), values %$stash;
    @{$MAKERS{$target}{not_methods}={}}{@not_methods} = @not_methods;
    $MAKERS{$target}{is_class} = 1;
    {
      no strict 'refs';
      @{"${target}::ISA"} = do {
        require Moo::Object; ('Moo::Object');
      } unless @{"${target}::ISA"};
    }
    if ($INC{'Moo/HandleMoose.pm'}) {
      Moo::HandleMoose::inject_fake_metaclass_for($target);
    }
  }
  
  sub unimport {
    my $target = caller;
    _unimport_coderefs($target, $MAKERS{$target});
  }
  
  sub _set_superclasses {
    my $class = shift;
    my $target = shift;
    foreach my $superclass (@_) {
      _load_module($superclass);
      if ($INC{'Role/Tiny.pm'} && Role::Tiny->is_role($superclass)) {
        require Carp;
        Carp::croak("Can't extend role '$superclass'");
      }
    }
    # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
    @{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
    if (my $old = delete $Moo::MAKERS{$target}{constructor}) {
      $old->assert_constructor;
      delete _getstash($target)->{new};
      Moo->_constructor_maker_for($target)
         ->register_attribute_specs(%{$old->all_attribute_specs});
    }
    elsif (!$target->isa('Moo::Object')) {
      Moo->_constructor_maker_for($target);
    }
    no warnings 'once'; # piss off. -- mst
    $Moo::HandleMoose::MOUSE{$target} = [
      grep defined, map Mouse::Util::find_meta($_), @_
    ] if Mouse::Util->can('find_meta');
  }
  
  sub _maybe_reset_handlemoose {
    my ($class, $target) = @_;
    if ($INC{"Moo/HandleMoose.pm"}) {
      Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
    }
  }
  
  sub _accessor_maker_for {
    my ($class, $target) = @_;
    return unless $MAKERS{$target};
    $MAKERS{$target}{accessor} ||= do {
      my $maker_class = do {
        if (my $m = do {
              require Sub::Defer;
              if (my $defer_target =
                    (Sub::Defer::defer_info($target->can('new'))||[])->[0]
                ) {
                my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
                $MAKERS{$pkg} && $MAKERS{$pkg}{accessor};
              } else {
                undef;
              }
            }) {
          ref($m);
        } else {
          require Method::Generate::Accessor;
          'Method::Generate::Accessor'
        }
      };
      $maker_class->new;
    }
  }
  
  sub _constructor_maker_for {
    my ($class, $target) = @_;
    return unless $MAKERS{$target};
    $MAKERS{$target}{constructor} ||= do {
      require Method::Generate::Constructor;
      require Sub::Defer;
  
      my %construct_opts = (
        package => $target,
        accessor_generator => $class->_accessor_maker_for($target),
        subconstructor_handler => (
          '      if ($Moo::MAKERS{$class}) {'."\n"
          .'        if ($Moo::MAKERS{$class}{constructor}) {'."\n"
          .'          return $class->'.$target.'::SUPER::new(@_);'."\n"
          .'        }'."\n"
          .'        '.$class.'->_constructor_maker_for($class);'."\n"
          .'        return $class->new(@_)'.";\n"
          .'      } elsif ($INC{"Moose.pm"} and my $meta = Class::MOP::get_metaclass_by_name($class)) {'."\n"
          .'        return $meta->new_object('."\n"
          .'          $class->can("BUILDARGS") ? $class->BUILDARGS(@_)'."\n"
          .'                      : $class->Moo::Object::BUILDARGS(@_)'."\n"
          .'        );'."\n"
          .'      }'."\n"
        ),
      );
  
      my $con;
      my @isa = @{mro::get_linear_isa($target)};
      shift @isa;
      if (my ($parent_new) = grep { *{_getglob($_.'::new')}{CODE} } @isa) {
        if ($parent_new eq 'Moo::Object') {
          # no special constructor needed
        }
        elsif (my $makers = $MAKERS{$parent_new}) {
          $con = $makers->{constructor};
          $construct_opts{construction_string} = $con->construction_string
            if $con;
        }
        elsif ($parent_new->can('BUILDALL')) {
          $construct_opts{construction_builder} = sub {
            my $inv = $target->can('BUILDARGS') ? '' : 'Moo::Object::';
            'do {'
            .'  my $args = $class->'.$inv.'BUILDARGS(@_);'
            .'  $args->{__no_BUILD__} = 1;'
            .'  $class->'.$target.'::SUPER::new($args);'
            .'}'
          };
        }
        else {
          $construct_opts{construction_builder} = sub {
            '$class->'.$target.'::SUPER::new('
              .($target->can('FOREIGNBUILDARGS') ?
                '$class->FOREIGNBUILDARGS(@_)' : '@_')
              .')'
          };
        }
      }
      ($con ? ref($con) : 'Method::Generate::Constructor')
        ->new(%construct_opts)
        ->install_delayed
        ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
    }
  }
  
  sub _concrete_methods_of {
    my ($me, $role) = @_;
    my $makers = $MAKERS{$role};
    # grab role symbol table
    my $stash = _getstash($role);
    # reverse so our keys become the values (captured coderefs) in case
    # they got copied or re-used since
    my $not_methods = { reverse %{$makers->{not_methods}||{}} };
    +{
      # grab all code entries that aren't in the not_methods list
      map {
        my $code = *{$stash->{$_}}{CODE};
        ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code)
      } grep !ref($stash->{$_}), keys %$stash
    };
  }
  
  1;
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  Moo - Minimalist Object Orientation (with Moose compatibility)
  
  =head1 SYNOPSIS
  
   package Cat::Food;
  
   use Moo;
   use strictures 2;
   use namespace::clean;
  
   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 => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 },
   );
  
   1;
  
  And elsewhere:
  
   my $full = Cat::Food->new(
      taste  => 'DELICIOUS.',
      brand  => 'SWEET-TREATZ',
      pounds => 10,
   );
  
   $full->feed_lion;
  
   say $full->pounds;
  
  =head1 DESCRIPTION
  
  C<Moo> is an extremely light-weight Object Orientation system. It allows one to
  concisely define objects and roles with a convenient syntax that avoids the
  details of Perl's object system.  C<Moo> contains a subset of L<Moose> and is
  optimised for rapid startup.
  
  C<Moo> avoids depending on any XS modules to allow for simple deployments.  The
  name C<Moo> is based on the idea that it provides almost -- but not quite --
  two thirds of L<Moose>.
  
  Unlike L<Mouse> this module does not aim at full compatibility with
  L<Moose>'s surface syntax, preferring instead to provide full interoperability
  via the metaclass inflation capabilities described in L</MOO AND MOOSE>.
  
  For a full list of the minor differences between L<Moose> and L<Moo>'s surface
  syntax, see L</INCOMPATIBILITIES WITH MOOSE>.
  
  =head1 WHY MOO EXISTS
  
  If you want a full object system with a rich Metaprotocol, L<Moose> is
  already wonderful.
  
  But if you don't want to use L<Moose>, you may not want "less metaprotocol"
  like L<Mouse> offers, but you probalby want "no metaprotocol", which is what
  Moo provides. C<Moo> is ideal for some situations where deployment or startup
  time precludes using L<Moose> and L<Mouse>:
  
  =over 2
  
  =item a command line or CGI script where fast startup is essential
  
  =item code designed to be deployed as a single file via L<App::FatPacker>
  
  =item a CPAN module that may be used by others in the above situations
  
  =back
  
  C<Moo> maintains transparent compatibility with L<Moose> so if you install and
  load L<Moose> you can use Moo clases and roles in L<Moose> code without
  modification.
  
  Moo -- Minimal Object Orientation -- aims to make it smooth to upgrade to
  L<Moose> when you need more than the minimal features offered by Moo.
  
  =head1 MOO AND MOOSE
  
  If L<Moo> detects L<Moose> being loaded, it will automatically register
  metaclasses for your L<Moo> and L<Moo::Role> packages, so you should be able
  to use them in L<Moose> code without modification.
  
  L<Moo> will also create L<Moose type constraints|Moose::Manual::Types> for
  L<Moo> classes and roles, so that in Moose classes C<< isa => 'MyMooClass' >>
  and C<< isa => 'MyMooRole' >> work the same as for L<Moose> classes and roles.
  
  Extending a L<Moose> class or consuming a L<Moose::Role> will also work.
  
  Extending a L<Mouse> class or consuming a L<Mouse::Role> will also work. But
  note that we don't provide L<Mouse> metaclasses or metaroles so the other way
  around doesn't work. This feature exists for L<Any::Moose> users porting to
  L<Moo>; enabling L<Mouse> users to use L<Moo> classes is not a priority for us.
  
  This means that there is no need for anything like L<Any::Moose> for Moo
  code - Moo and Moose code should simply interoperate without problem. To
  handle L<Mouse> code, you'll likely need an empty Moo role or class consuming
  or extending the L<Mouse> stuff since it doesn't register true L<Moose>
  metaclasses like L<Moo> does.
  
  If you need to disable the metaclass creation, add:
  
    no Moo::sification;
  
  to your code before Moose is loaded, but bear in mind that this switch is
  global and turns the mechanism off entirely so don't put this in library code.
  
  =head1 MOO AND CLASS::XSACCESSOR
  
  If a new enough version of L<Class::XSAccessor> is available, it
  will be used to generate simple accessors, readers, and writers for
  better performance.  Simple accessors are those without lazy defaults,
  type checks/coercions, or triggers.  Readers and writers generated
  by L<Class::XSAccessor> will behave slightly differently: they will
  reject attempts to call them with the incorrect number of parameters.
  
  =head1 MOO VERSUS ANY::MOOSE
  
  L<Any::Moose> will load L<Mouse> normally, and L<Moose> in a program using
  L<Moose> - which theoretically allows you to get the startup time of L<Mouse>
  without disadvantaging L<Moose> users.
  
  Sadly, this doesn't entirely work, since the selection is load order dependent
  - L<Moo>'s metaclass inflation system explained above in L</MOO AND MOOSE> is
  significantly more reliable.
  
  So if you want to write a CPAN module that loads fast or has only pure perl
  dependencies but is also fully usable by L<Moose> users, you should be using
  L<Moo>.
  
  For a full explanation, see the article
  L<http://shadow.cat/blog/matt-s-trout/moo-versus-any-moose> which explains
  the differing strategies in more detail and provides a direct example of
  where L<Moo> succeeds and L<Any::Moose> fails.
  
  =head1 IMPORTED METHODS
  
  =head2 new
  
   Foo::Bar->new( attr1 => 3 );
  
  or
  
   Foo::Bar->new({ attr1 => 3 });
  
  =head2 BUILDARGS
  
   sub BUILDARGS {
     my ( $class, @args ) = @_;
  
     unshift @args, "attr1" if @args % 2 == 1;
  
     return { @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 FOREIGNBUILDARGS
  
  If you are inheriting from a non-Moo class, the arguments passed to the parent
  class constructor can be manipulated by defining a C<FOREIGNBUILDARGS> method.
  It will receive the same arguments as C<BUILDARGS>, and should return a list
  of arguments to pass to the parent class constructor.
  
  =head2 BUILD
  
  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 DEMOLISH
  
  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 a base class. Multiple superclasses can be passed for multiple
  inheritance but please consider using L<roles|Moo::Role> instead.  The class
  will be loaded but no errors will be triggered if the class can't be found and
  there are already subs in the class.
  
  Calling extends more than once will REPLACE your superclasses, not add to
  them like 'use base' would.
  
  =head2 with
  
   with 'Some::Role1';
  
  or
  
   with 'Some::Role1', 'Some::Role2';
  
  Composes one or more L<Moo::Role> (or L<Role::Tiny>) roles into the current
  class.  An error will be raised if these roles cannot be composed because they
  have conflicting method definitions.  The roles will be loaded using the same
  mechansim as C<extends> uses.
  
  =head2 has
  
   has attr => (
     is => 'ro',
   );
  
  Declares an attribute for the class.
  
   package Foo;
   use Moo;
   has 'attr' => (
     is => 'ro'
   );
  
   package Bar;
   use Moo;
   extends 'Foo';
   has '+attr' => (
     default => sub { "blah" },
   );
  
  Using the C<+> notation, it's possible to override an attribute.
  
  The options for C<has> are as follows:
  
  =over 2
  
  =item * C<is>
  
  B<required>, may be C<ro>, C<lazy>, C<rwp> or C<rw>.
  
  C<ro> stands for "read-only" and generates an accessor that dies if you attempt
  to write to it - i.e.  a getter only - by defaulting C<reader> to the name of
  the attribute.
  
  C<lazy> generates a reader like C<ro>, but also sets C<lazy> to 1 and
  C<builder> to C<_build_${attribute_name}> to allow on-demand generated
  attributes.  This feature was my attempt to fix my incompetence when
  originally designing C<lazy_build>, and is also implemented by
  L<MooseX::AttributeShortcuts>. There is, however, nothing to stop you
  using C<lazy> and C<builder> yourself with C<rwp> or C<rw> - it's just that
  this isn't generally a good idea so we don't provide a shortcut for it.
  
  C<rwp> stands for "read-write protected" and generates a reader like C<ro>, but
  also sets C<writer> to C<_set_${attribute_name}> for attributes that are
  designed to be written from inside of the class, but read-only from outside.
  This feature comes from L<MooseX::AttributeShortcuts>.
  
  C<rw> stands for "read-write" and generates a normal getter/setter by
  defaulting the C<accessor> to the name of the attribute specified.
  
  =item * C<isa>
  
  Takes a coderef which is used 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
  
   use Scalar::Util qw(looks_like_number);
   ...
   isa => sub {
     die "$_[0] is not a number!" unless looks_like_number $_[0]
   },
  
  Note that the return value for C<isa> is discarded. Only if the sub dies does
  type validation fail.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  Since L<Moo> does B<not> run the C<isa> check before C<coerce> if a coercion
  subroutine has been supplied, C<isa> checks are not structural to your code
  and can, if desired, be omitted on non-debug builds (although if this results
  in an uncaught bug causing your program to break, the L<Moo> authors guarantee
  nothing except that you get to keep both halves).
  
  If you want L<Moose> compatible or L<MooseX::Types> style named types, look at
  L<Type::Tiny>.
  
  To cause your C<isa> entries to be automatically mapped to named
  L<Moose::Meta::TypeConstraint> objects (rather than the default behaviour
  of creating an anonymous type), set:
  
    $Moo::HandleMoose::TYPE_MAP{$isa_coderef} = sub {
      require MooseX::Types::Something;
      return MooseX::Types::Something::TypeName();
    };
  
  Note that this example is purely illustrative; anything that returns a
  L<Moose::Meta::TypeConstraint> object or something similar enough to it to
  make L<Moose> happy is fine.
  
  =item * C<coerce>
  
  Takes a coderef which is meant to coerce the attribute.  The basic idea is to
  do something like the following:
  
   coerce => sub {
     $_[0] % 2 ? $_[0] : $_[0] + 1
   },
  
  Note that L<Moo> will always execute your coercion: this is to permit
  C<isa> entries to be used purely for bug trapping, whereas coercions are
  always structural to your code. We do, however, apply any supplied C<isa>
  check after the coercion has run to ensure that it returned a valid value.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  If the C<isa> option is a blessed object providing a C<coerce> or
  C<coercion> method, then the C<coerce> option may be set to just C<1>.
  
  =item * C<handles>
  
  Takes a string
  
    handles => 'RobotRole'
  
  Where C<RobotRole> is a L<role|Moo::Role> that defines an interface which
  becomes the list of methods to handle.
  
  Takes a list of methods
  
   handles => [ qw( one two ) ]
  
  Takes a hashref
  
   handles => {
     un => 'one',
   }
  
  =item * C<trigger>
  
  Takes a coderef which will get called any time the attribute is set. This
  includes the constructor, but not default or built values. The coderef will be
  invoked against the object with the new value as an argument.
  
  If you set this to just C<1>, it generates a trigger which calls the
  C<_trigger_${attr_name}> method on C<$self>. This feature comes from
  L<MooseX::AttributeShortcuts>.
  
  Note that Moose also passes the old value, if any; this feature is not yet
  supported.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * C<default>
  
  Takes a coderef which will get called with $self as its only argument to
  populate an attribute if no value for that attribute was supplied to the
  constructor. Alternatively, if the attribute is lazy, C<default> executes when
  the attribute is first retrieved if no value has yet been provided.
  
  If a simple scalar is provided, it will be inlined as a string. Any non-code
  reference (hash, array) will result in an error - for that case instead use
  a code reference that returns the desired value.
  
  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 * C<predicate>
  
  Takes a method name which will return true if an attribute has a value.
  
  If you set this to just C<1>, the predicate is automatically named
  C<has_${attr_name}> if your attribute's name does not start with an
  underscore, or C<_has_${attr_name_without_the_underscore}> if it does.
  This feature comes from L<MooseX::AttributeShortcuts>.
  
  =item * C<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;
  
  The following features come from L<MooseX::AttributeShortcuts>:
  
  If you set this to just C<1>, the builder is automatically named
  C<_build_${attr_name}>.
  
  If you set this to a coderef or code-convertible object, that variable will be
  installed under C<$class::_build_${attr_name}> and the builder set to the same
  name.
  
  =item * C<clearer>
  
  Takes a method name which will clear the attribute.
  
  If you set this to just C<1>, the clearer is automatically named
  C<clear_${attr_name}> if your attribute's name does not start with an
  underscore, or C<_clear_${attr_name_without_the_underscore}> if it does.
  This feature comes from L<MooseX::AttributeShortcuts>.
  
  B<NOTE:> If the attribute is C<lazy>, it will be regenerated from C<default> or
  C<builder> the next time it is accessed. If it is not lazy, it will be C<undef>.
  
  =item * C<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 * C<required>
  
  B<Boolean>.  Set this if the attribute must be passed on object instantiation.
  
  =item * C<reader>
  
  The name of the method that returns the value of the attribute.  If you like
  Java style methods, you might set this to C<get_foo>
  
  =item * C<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 * C<weak_ref>
  
  B<Boolean>.  Set this if you want the reference that the attribute contains to
  be weakened. Use this when circular references, which cause memory leaks, are
  possible.
  
  =item * C<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
  is ignored.
  
  =item * C<moosify>
  
  Takes either a coderef or array of coderefs which is meant to transform the
  given attributes specifications if necessary when upgrading to a Moose role or
  class. You shouldn't need this by default, but is provided as a means of
  possible extensibility.
  
  =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.
  
  To do this, you can write
  
    use Sub::Quote;
  
    use Moo;
    use namespace::clean;
  
    has foo => (
      is => 'ro',
      isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 })
    );
  
  which will be inlined as
  
    do {
      local @_ = ($_[0]->{foo});
      die "Not <3" unless $_[0] < 3;
    }
  
  or to avoid localizing @_,
  
    has foo => (
      is => 'ro',
      isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 })
    );
  
  which will be inlined as
  
    do {
      my ($val) = ($_[0]->{foo});
      die "Not <3" unless $val < 3;
    }
  
  See L<Sub::Quote> for more information, including how to pass lexical
  captures that will also be compiled into the subroutine.
  
  =head1 CLEANING UP IMPORTS
  
  L<Moo> will not clean up imported subroutines for you; you will have
  to do that manually. The recommended way to do this is to declare your
  imports first, then C<use Moo>, then C<use namespace::clean>.
  Anything imported before L<namespace::clean> will be scrubbed.
  Anything imported or declared after will be still be available.
  
   package Record;
  
   use Digest::MD5 qw(md5_hex);
  
   use Moo;
   use namespace::clean;
  
   has name => (is => 'ro', required => 1);
   has id => (is => 'lazy');
   sub _build_id {
     my ($self) = @_;
     return md5_hex($self->name);
   }
  
   1;
  
  If you were to import C<md5_hex> after L<namespace::clean> you would
  be able to call C<< ->md5_hex() >> on your C<Record> instances (and it
  probably wouldn't do what you expect!).
  
  L<Moo::Role>s behave slightly differently.  Since their methods are
  composed into the consuming class, they can do a little more for you
  automatically.  As long as you declare your imports before calling
  C<use Moo::Role>, those imports and the ones L<Moo::Role> itself
  provides will not be composed into consuming classes so there's usually
  no need to use L<namespace::clean>.
  
  B<On L<namespace::autoclean>:> Older versions of L<namespace::autoclean> would
  inflate Moo classes to full L<Moose> classes, losing the benefits of Moo.  If
  you want to use L<namespace::autoclean> with a Moo class, make sure you are
  using version 0.16 or newer.
  
  =head1 INCOMPATIBILITIES WITH MOOSE
  
  There is no built-in type system.  C<isa> is verified with a coderef; if you
  need complex types, L<Type::Tiny> can provide types, type libraries, and
  will work seamlessly with both L<Moo> and L<Moose>.  L<Type::Tiny> can be
  considered the successor to L<MooseX::Types> and provides a similar API, so
  that you can write
  
    use Types::Standard;
    has days_to_live => (is => 'ro', isa => Int);
  
  C<initializer> is not supported in core since the author considers it to be a
  bad idea and Moose best practices recommend avoiding it. Meanwhile C<trigger> or
  C<coerce> are more likely to be able to fulfill your needs.
  
  There is no meta object.  If you need this level of complexity you need
  L<Moose> - Moo is small because it explicitly does not provide a metaprotocol.
  However, if you load L<Moose>, then
  
    Class::MOP::class_of($moo_class_or_role)
  
  will return an appropriate metaclass pre-populated by L<Moo>.
  
  No support for C<super>, C<override>, C<inner>, or C<augment> - the author
  considers augment to be a bad idea, and override can be translated:
  
    override foo => sub {
      ...
      super();
      ...
    };
  
    around foo => sub {
      my ($orig, $self) = (shift, shift);
      ...
      $self->$orig(@_);
      ...
    };
  
  The C<dump> method is not provided by default. The author suggests loading
  L<Devel::Dwarn> into C<main::> (via C<perl -MDevel::Dwarn ...> for example) and
  using C<$obj-E<gt>$::Dwarn()> instead.
  
  L</default> only supports coderefs and plain scalars, because passing a hash
  or array reference as a default is almost always incorrect since the value is
  then shared between all objects using that default.
  
  C<lazy_build> is not supported; you are instead encouraged to use the
  C<< is => 'lazy' >> option supported by L<Moo> and
  L<MooseX::AttributeShortcuts>.
  
  C<auto_deref> is not supported since the author considers it a bad idea and
  it has been considered best practice to avoid it for some time.
  
  C<documentation> will show up in a L<Moose> metaclass created from your class
  but is otherwise ignored. Then again, L<Moose> ignores it as well, so this
  is arguably not an incompatibility.
  
  Since C<coerce> does not require C<isa> to be defined but L<Moose> does
  require it, the metaclass inflation for coerce alone is a trifle insane
  and if you attempt to subtype the result will almost certainly break.
  
  C<BUILDARGS> is not triggered if your class does not have any attributes.
  Without attributes, C<BUILDARGS> return value would be ignored, so we just
  skip calling the method instead.
  
  Handling of warnings: when you C<use Moo> we enable strict and warnings, in a
  similar way to Moose. The authors recommend the use of C<strictures>, which
  enables FATAL warnings, and several extra pragmas when used in development:
  L<indirect>, L<multidimensional>, and L<bareword::filehandles>.
  
  Additionally, L<Moo> supports a set of attribute option shortcuts intended to
  reduce common boilerplate.  The set of shortcuts is the same as in the L<Moose>
  module L<MooseX::AttributeShortcuts> as of its version 0.009+.  So if you:
  
      package MyClass;
      use Moo;
      use strictures 2;
  
  The nearest L<Moose> invocation would be:
  
      package MyClass;
  
      use Moose;
      use warnings FATAL => "all";
      use MooseX::AttributeShortcuts;
  
  or, if you're inheriting from a non-Moose class,
  
      package MyClass;
  
      use Moose;
      use MooseX::NonMoose;
      use warnings FATAL => "all";
      use MooseX::AttributeShortcuts;
  
  Finally, Moose requires you to call
  
      __PACKAGE__->meta->make_immutable;
  
  at the end of your class to get an inlined (i.e. not horribly slow)
  constructor. Moo does it automatically the first time ->new is called
  on your class. (C<make_immutable> is a no-op in Moo to ease migration.)
  
  An extension L<MooX::late> exists to ease translating Moose packages
  to Moo by providing a more Moose-like interface.
  
  =head1 SUPPORT
  
  Users' IRC: #moose on irc.perl.org
  
  =for :html
  L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org>
  
  Development and contribution IRC: #web-simple on irc.perl.org
  
  =for :html
  L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org>
  
  Bugtracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Moo>
  
  Git repository: L<git://github.com/moose/Moo.git>
  
  Git browser: L<https://github.com/moose/Moo>
  
  =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>
  
  perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org>
  
  Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
  
  ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
  
  tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
  
  haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
  
  mattp - Matt Phillips (cpan:MATTP) <mattp@cpan.org>
  
  bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
  
  bubaflub - Bob Kuo (cpan:BUBAFLUB) <bubaflub@cpan.org>
  
  ether = Karen Etheridge (cpan:ETHER) <ether@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010-2015 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. See L<http://dev.perl.org/licenses/>.
  
  =cut
MOO

$fatpacked{"Moo/HandleMoose.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_HANDLEMOOSE';
  package Moo::HandleMoose;
  use Moo::_strictures;
  no warnings 'once';
  use Moo::_Utils;
  use Sub::Quote qw(quotify);
  
  our %TYPE_MAP;
  
  our $SETUP_DONE;
  
  sub import { return if $SETUP_DONE; inject_all(); $SETUP_DONE = 1; }
  
  sub inject_all {
    die "Can't inflate Moose metaclass with Moo::sification disabled"
      if $Moo::sification::disabled;
    require Class::MOP;
    inject_fake_metaclass_for($_)
      for grep $_ ne 'Moo::Object', do { no warnings 'once'; keys %Moo::MAKERS };
    inject_fake_metaclass_for($_) for keys %Moo::Role::INFO;
    require Moose::Meta::Method::Constructor;
    @Moo::HandleMoose::FakeConstructor::ISA = 'Moose::Meta::Method::Constructor';
    @Moo::HandleMoose::FakeMeta::ISA = 'Moose::Meta::Method::Meta';
  }
  
  sub maybe_reinject_fake_metaclass_for {
    my ($name) = @_;
    our %DID_INJECT;
    if (delete $DID_INJECT{$name}) {
      unless ($Moo::Role::INFO{$name}) {
        Moo->_constructor_maker_for($name)->install_delayed;
      }
      inject_fake_metaclass_for($name);
    }
  }
  
  sub inject_fake_metaclass_for {
    my ($name) = @_;
    require Class::MOP;
    require Moo::HandleMoose::FakeMetaClass;
    Class::MOP::store_metaclass_by_name(
      $name, bless({ name => $name }, 'Moo::HandleMoose::FakeMetaClass')
    );
    require Moose::Util::TypeConstraints;
    if ($Moo::Role::INFO{$name}) {
      Moose::Util::TypeConstraints::find_or_create_does_type_constraint($name);
    } else {
      Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($name);
    }
  }
  
  {
    package Moo::HandleMoose::FakeConstructor;
  
    sub _uninlined_body { \&Moose::Object::new }
  }
  
  sub inject_real_metaclass_for {
    my ($name) = @_;
    our %DID_INJECT;
    return Class::MOP::get_metaclass_by_name($name) if $DID_INJECT{$name};
    require Moose; require Moo; require Moo::Role; require Scalar::Util;
    Class::MOP::remove_metaclass_by_name($name);
    my ($am_role, $am_class, $meta, $attr_specs, $attr_order) = do {
      if (my $info = $Moo::Role::INFO{$name}) {
        my @attr_info = @{$info->{attributes}||[]};
        (1, 0, Moose::Meta::Role->initialize($name),
         { @attr_info },
         [ @attr_info[grep !($_ % 2), 0..$#attr_info] ]
        )
      } elsif ( my $cmaker = Moo->_constructor_maker_for($name) ) {
        my $specs = $cmaker->all_attribute_specs;
        (0, 1, Moose::Meta::Class->initialize($name), $specs,
         [ sort { $specs->{$a}{index} <=> $specs->{$b}{index} } keys %$specs ]
        );
      } else {
         # This codepath is used if $name does not exist in $Moo::MAKERS
         (0, 0, Moose::Meta::Class->initialize($name), {}, [] )
      }
    };
  
    foreach my $spec (values %$attr_specs) {
      if (my $inflators = delete $spec->{moosify}) {
        $_->($spec) for @$inflators;
      }
    }
  
    my %methods
      = %{($am_role ? 'Moo::Role' : 'Moo')->_concrete_methods_of($name)};
  
    # if stuff gets added afterwards, _maybe_reset_handlemoose should
    # trigger the recreation of the metaclass but we need to ensure the
    # Moo::Role cache is cleared so we don't confuse Moo itself.
    if (my $info = $Moo::Role::INFO{$name}) {
      delete $info->{methods};
    }
  
    # needed to ensure the method body is stable and get things named
    Sub::Defer::undefer_sub($_) for grep defined, values %methods;
    my @attrs;
    {
      # This local is completely not required for roles but harmless
      local @{_getstash($name)}{keys %methods};
      my %seen_name;
      foreach my $name (@$attr_order) {
        $seen_name{$name} = 1;
        my %spec = %{$attr_specs->{$name}};
        my %spec_map = (
          map { $_->name => $_->init_arg||$_->name }
          (
            (grep { $_->has_init_arg }
               $meta->attribute_metaclass->meta->get_all_attributes),
            grep { exists($_->{init_arg}) ? defined($_->init_arg) : 1 }
            map {
              my $meta = Moose::Util::resolve_metatrait_alias('Attribute', $_)
                           ->meta;
              map $meta->get_attribute($_), $meta->get_attribute_list
            }  @{$spec{traits}||[]}
          )
        );
        # have to hard code this because Moose's role meta-model is lacking
        $spec_map{traits} ||= 'traits';
  
        $spec{is} = 'ro' if $spec{is} eq 'lazy' or $spec{is} eq 'rwp';
        my $coerce = $spec{coerce};
        if (my $isa = $spec{isa}) {
          my $tc = $spec{isa} = do {
            if (my $mapped = $TYPE_MAP{$isa}) {
              my $type = $mapped->();
              unless ( Scalar::Util::blessed($type)
                  && $type->isa("Moose::Meta::TypeConstraint") ) {
                die "error inflating attribute '$name' for package '$_[0]': "
                  ."\$TYPE_MAP{$isa} did not return a valid type constraint'";
              }
              $coerce ? $type->create_child_type(name => $type->name) : $type;
            } else {
              Moose::Meta::TypeConstraint->new(
                constraint => sub { eval { &$isa; 1 } }
              );
            }
          };
          if ($coerce) {
            $tc->coercion(Moose::Meta::TypeCoercion->new)
               ->_compiled_type_coercion($coerce);
            $spec{coerce} = 1;
          }
        } elsif ($coerce) {
          my $attr = quotify($name);
          my $tc = Moose::Meta::TypeConstraint->new(
                     constraint => sub { die "This is not going to work" },
                     inlined => sub {
                        'my $r = $_[42]{'.$attr.'}; $_[42]{'.$attr.'} = 1; $r'
                     },
                   );
          $tc->coercion(Moose::Meta::TypeCoercion->new)
             ->_compiled_type_coercion($coerce);
          $spec{isa} = $tc;
          $spec{coerce} = 1;
        }
        %spec =
          map { $spec_map{$_} => $spec{$_} }
          grep { exists $spec_map{$_} }
          keys %spec;
        push @attrs, $meta->add_attribute($name => %spec);
      }
      foreach my $mouse (do { our %MOUSE; @{$MOUSE{$name}||[]} }) {
        foreach my $attr ($mouse->get_all_attributes) {
          my %spec = %{$attr};
          delete @spec{qw(
            associated_class associated_methods __METACLASS__
            provides curries
          )};
          my $name = delete $spec{name};
          next if $seen_name{$name}++;
          push @attrs, $meta->add_attribute($name => %spec);
        }
      }
    }
    foreach my $meth_name (keys %methods) {
      my $meth_code = $methods{$meth_name};
      $meta->add_method($meth_name, $meth_code) if $meth_code;
    }
  
    if ($am_role) {
      my $info = $Moo::Role::INFO{$name};
      $meta->add_required_methods(@{$info->{requires}});
      foreach my $modifier (@{$info->{modifiers}}) {
        my ($type, @args) = @$modifier;
        my $code = pop @args;
        $meta->${\"add_${type}_method_modifier"}($_, $code) for @args;
      }
    }
    elsif ($am_class) {
      foreach my $attr (@attrs) {
        foreach my $method (@{$attr->associated_methods}) {
          $method->{body} = $name->can($method->name);
        }
      }
      bless(
        $meta->find_method_by_name('new'),
        'Moo::HandleMoose::FakeConstructor',
      );
      my $meta_meth;
      if (
        $meta_meth = $meta->find_method_by_name('meta')
        and $meta_meth->body == \&Moo::Object::meta
      ) {
        bless($meta_meth, 'Moo::HandleMoose::FakeMeta');
      }
      # a combination of Moo and Moose may bypass a Moo constructor but still
      # use a Moo DEMOLISHALL.  We need to make sure this is loaded before
      # global destruction.
      require Method::Generate::DemolishAll;
    }
    $meta->add_role(Class::MOP::class_of($_))
      for grep !/\|/ && $_ ne $name, # reject Foo|Bar and same-role-as-self
        do { no warnings 'once'; keys %{$Moo::Role::APPLIED_TO{$name}} };
    $DID_INJECT{$name} = 1;
    $meta;
  }
  
  1;
MOO_HANDLEMOOSE

$fatpacked{"Moo/HandleMoose/FakeMetaClass.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_HANDLEMOOSE_FAKEMETACLASS';
  package Moo::HandleMoose::FakeMetaClass;
  use Moo::_strictures;
  
  sub DESTROY { }
  
  sub AUTOLOAD {
    my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/);
    my $self = shift;
    die "Can't call $meth without object instance"
      if !ref $self;
    die "Can't inflate Moose metaclass with Moo::sification disabled"
      if $Moo::sification::disabled;
    require Moo::HandleMoose;
    Moo::HandleMoose::inject_real_metaclass_for($self->{name})->$meth(@_)
  }
  sub can {
    my $self = shift;
    return $self->SUPER::can(@_)
      if !ref $self or $Moo::sification::disabled;
    require Moo::HandleMoose;
    Moo::HandleMoose::inject_real_metaclass_for($self->{name})->can(@_)
  }
  sub isa {
    my $self = shift;
    return $self->SUPER::isa(@_)
      if !ref $self or $Moo::sification::disabled;
    require Moo::HandleMoose;
    Moo::HandleMoose::inject_real_metaclass_for($self->{name})->isa(@_)
  }
  sub make_immutable { $_[0] }
  
  1;
MOO_HANDLEMOOSE_FAKEMETACLASS

$fatpacked{"Moo/HandleMoose/_TypeMap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_HANDLEMOOSE__TYPEMAP';
  package Moo::HandleMoose::_TypeMap;
  use Moo::_strictures;
  
  package
    Moo::HandleMoose;
  our %TYPE_MAP;
  
  package Moo::HandleMoose::_TypeMap;
  
  use Scalar::Util ();
  use Config;
  
  our %WEAK_TYPES;
  
  sub _str_to_ref {
    my $in = shift;
    return $in
      if ref $in;
  
    if ($in =~ /(?:^|=)[A-Z]+\(0x([0-9a-zA-Z]+)\)$/) {
      my $id = do { no warnings 'portable'; hex "$1" };
      require B;
      my $sv = bless \$id, 'B::SV';
      my $ref = eval { $sv->object_2svref };
      if (!defined $ref) {
        die <<'END_ERROR';
  Moo initialization encountered types defined in a parent thread - ensure that
  Moo is require()d before any further thread spawns following a type definition.
  END_ERROR
      }
      return $ref;
    }
    return $in;
  }
  
  sub TIEHASH  { bless {}, $_[0] }
  
  sub STORE {
    my ($self, $key, $value) = @_;
    my $type = _str_to_ref($key);
    $WEAK_TYPES{$type} = $type;
    Scalar::Util::weaken($WEAK_TYPES{$type})
      if ref $type;
    $self->{$key} = $value;
  }
  
  sub FETCH    { $_[0]->{$_[1]} }
  sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
  sub NEXTKEY  { each %{$_[0]} }
  sub EXISTS   { exists $_[0]->{$_[1]} }
  sub DELETE   { delete $_[0]->{$_[1]} }
  sub CLEAR    { %{$_[0]} = () }
  sub SCALAR   { scalar %{$_[0]} }
  
  sub CLONE {
    my @types = map {
      defined $WEAK_TYPES{$_} ? ($WEAK_TYPES{$_} => $TYPE_MAP{$_}) : ()
    } keys %TYPE_MAP;
    %WEAK_TYPES = ();
    %TYPE_MAP = @types;
  }
  
  sub DESTROY {
    my %types = %{$_[0]};
    untie %TYPE_MAP;
    %TYPE_MAP = %types;
  }
  
  if ($Config{useithreads}) {
    my @types = %TYPE_MAP;
    tie %TYPE_MAP, __PACKAGE__;
    %TYPE_MAP = @types;
  }
  
  1;
MOO_HANDLEMOOSE__TYPEMAP

$fatpacked{"Moo/Object.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_OBJECT';
  package Moo::Object;
  
  use Moo::_strictures;
  
  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 {
          require Method::Generate::DemolishAll;
          Method::Generate::DemolishAll->new
        })->generate_method($class);
      }
    }
    my $proto = $class->BUILDARGS(@_);
    $NO_BUILD{$class} and
      return bless({}, $class);
    $NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class};
    $NO_BUILD{$class}
      ? bless({}, $class)
      : bless({}, $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 {
      require Method::Generate::BuildAll;
      Method::Generate::BuildAll->new
    })->generate_method(ref($self)))}(@_);
  }
  
  sub DEMOLISHALL {
    my $self = shift;
    $self->${\(($DEMOLISH_MAKER ||= do {
      require Method::Generate::DemolishAll;
      Method::Generate::DemolishAll->new
    })->generate_method(ref($self)))}(@_);
  }
  
  sub does {
    return !!0
      unless ($INC{'Moose/Role.pm'} || $INC{'Role/Tiny.pm'});
    require Moo::Role;
    my $does = Moo::Role->can("does_role");
    { no warnings 'redefine'; *does = $does }
    goto &$does;
  }
  
  # duplicated in Moo::Role
  sub meta {
    require Moo::HandleMoose::FakeMetaClass;
    my $class = ref($_[0])||$_[0];
    bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
  }
  
  1;
MOO_OBJECT

$fatpacked{"Moo/Role.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_ROLE';
  package Moo::Role;
  
  use Moo::_strictures;
  use Moo::_Utils;
  use Role::Tiny ();
  our @ISA = qw(Role::Tiny);
  
  our $VERSION = '2.000002';
  $VERSION = eval $VERSION;
  
  require Moo::sification;
  Moo::sification->import;
  
  BEGIN {
      *INFO = \%Role::Tiny::INFO;
      *APPLIED_TO = \%Role::Tiny::APPLIED_TO;
      *ON_ROLE_CREATE = \@Role::Tiny::ON_ROLE_CREATE;
  }
  
  our %INFO;
  our %APPLIED_TO;
  our %APPLY_DEFAULTS;
  our @ON_ROLE_CREATE;
  
  sub _install_tracked {
    my ($target, $name, $code) = @_;
    $INFO{$target}{exports}{$name} = $code;
    _install_coderef "${target}::${name}" => "Moo::Role::${name}" => $code;
  }
  
  sub import {
    my $target = caller;
    my ($me) = @_;
  
    _set_loaded(caller);
    strict->import;
    warnings->import;
    if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) {
      die "Cannot import Moo::Role into a Moo class";
    }
    $INFO{$target} ||= {};
    # get symbol table reference
    my $stash = _getstash($target);
    _install_tracked $target => has => sub {
      my $name_proto = shift;
      my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
      if (@_ % 2 != 0) {
        require Carp;
        Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
          . " attribute(s): even number of arguments expected, got " . scalar @_)
      }
      my %spec = @_;
      foreach my $name (@name_proto) {
        my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
        ($INFO{$target}{accessor_maker} ||= do {
          require Method::Generate::Accessor;
          Method::Generate::Accessor->new
        })->generate_method($target, $name, $spec_ref);
        push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref;
        $me->_maybe_reset_handlemoose($target);
      }
    };
    # install before/after/around subs
    foreach my $type (qw(before after around)) {
      _install_tracked $target => $type => sub {
        require Class::Method::Modifiers;
        push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
        $me->_maybe_reset_handlemoose($target);
      };
    }
    _install_tracked $target => requires => sub {
      push @{$INFO{$target}{requires}||=[]}, @_;
      $me->_maybe_reset_handlemoose($target);
    };
    _install_tracked $target => with => sub {
      $me->apply_roles_to_package($target, @_);
      $me->_maybe_reset_handlemoose($target);
    };
    return if $me->is_role($target); # already exported into this package
    $INFO{$target}{is_role} = 1;
    *{_getglob("${target}::meta")} = $me->can('meta');
    # 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) with a map to the coderefs in case of copying or re-use
    my @not_methods = ('', map { *$_{CODE}||() } grep !ref($_), values %$stash);
    @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods;
    # a role does itself
    $APPLIED_TO{$target} = { $target => undef };
  
    $_->($target)
      for @ON_ROLE_CREATE;
  }
  
  push @ON_ROLE_CREATE, sub {
    my $target = shift;
    if ($INC{'Moo/HandleMoose.pm'}) {
      Moo::HandleMoose::inject_fake_metaclass_for($target);
    }
  };
  
  # duplicate from Moo::Object
  sub meta {
    require Moo::HandleMoose::FakeMetaClass;
    my $class = ref($_[0])||$_[0];
    bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
  }
  
  sub unimport {
    my $target = caller;
    _unimport_coderefs($target, $INFO{$target});
  }
  
  sub _maybe_reset_handlemoose {
    my ($class, $target) = @_;
    if ($INC{"Moo/HandleMoose.pm"}) {
      Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
    }
  }
  
  sub methods_provided_by {
    my ($self, $role) = @_;
    _load_module($role);
    $self->_inhale_if_moose($role);
    die "${role} is not a Moo::Role" unless $self->is_role($role);
    return $self->SUPER::methods_provided_by($role);
  }
  
  sub is_role {
    my ($self, $role) = @_;
    $self->_inhale_if_moose($role);
    $self->SUPER::is_role($role);
  }
  
  sub _inhale_if_moose {
    my ($self, $role) = @_;
    my $meta;
    if (!$self->SUPER::is_role($role)
        and (
          $INC{"Moose.pm"}
          and $meta = Class::MOP::class_of($role)
          and ref $meta ne 'Moo::HandleMoose::FakeMetaClass'
          and $meta->isa('Moose::Meta::Role')
        )
        or (
          Mouse::Util->can('find_meta')
          and $meta = Mouse::Util::find_meta($role)
          and $meta->isa('Mouse::Meta::Role')
       )
    ) {
      my $is_mouse = $meta->isa('Mouse::Meta::Role');
      $INFO{$role}{methods} = {
        map +($_ => $role->can($_)),
          grep $role->can($_),
          grep !($is_mouse && $_ eq 'meta'),
          grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
            $meta->get_method_list
      };
      $APPLIED_TO{$role} = {
        map +($_->name => 1), $meta->calculate_all_roles
      };
      $INFO{$role}{requires} = [ $meta->get_required_method_list ];
      $INFO{$role}{attributes} = [
        map +($_ => do {
          my $attr = $meta->get_attribute($_);
          my $spec = { %{ $is_mouse ? $attr : $attr->original_options } };
  
          if ($spec->{isa}) {
  
            my $get_constraint = do {
              my $pkg = $is_mouse
                          ? 'Mouse::Util::TypeConstraints'
                          : 'Moose::Util::TypeConstraints';
              _load_module($pkg);
              $pkg->can('find_or_create_isa_type_constraint');
            };
  
            my $tc = $get_constraint->($spec->{isa});
            my $check = $tc->_compiled_type_constraint;
  
            $spec->{isa} = sub {
              &$check or die "Type constraint failed for $_[0]"
            };
  
            if ($spec->{coerce}) {
  
               # Mouse has _compiled_type_coercion straight on the TC object
               $spec->{coerce} = $tc->${\(
                 $tc->can('coercion')||sub { $_[0] }
               )}->_compiled_type_coercion;
            }
          }
          $spec;
        }), $meta->get_attribute_list
      ];
      my $mods = $INFO{$role}{modifiers} = [];
      foreach my $type (qw(before after around)) {
        # Mouse pokes its own internals so we have to fall back to doing
        # the same thing in the absence of the Moose API method
        my $map = $meta->${\(
          $meta->can("get_${type}_method_modifiers_map")
          or sub { shift->{"${type}_method_modifiers"} }
        )};
        foreach my $method (keys %$map) {
          foreach my $mod (@{$map->{$method}}) {
            push @$mods, [ $type => $method => $mod ];
          }
        }
      }
      require Class::Method::Modifiers if @$mods;
      $INFO{$role}{inhaled_from_moose} = 1;
      $INFO{$role}{is_role} = 1;
    }
  }
  
  sub _maybe_make_accessors {
    my ($self, $target, $role) = @_;
    my $m;
    if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}
        or $INC{"Moo.pm"}
        and $m = Moo->_accessor_maker_for($target)
        and ref($m) ne 'Method::Generate::Accessor') {
      $self->_make_accessors($target, $role);
    }
  }
  
  sub _make_accessors_if_moose {
    my ($self, $target, $role) = @_;
    if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}) {
      $self->_make_accessors($target, $role);
    }
  }
  
  sub _make_accessors {
    my ($self, $target, $role) = @_;
    my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do {
      require Method::Generate::Accessor;
      Method::Generate::Accessor->new
    });
    my $con_gen = $Moo::MAKERS{$target}{constructor};
    my @attrs = @{$INFO{$role}{attributes}||[]};
    while (my ($name, $spec) = splice @attrs, 0, 2) {
      # needed to ensure we got an index for an arrayref based generator
      if ($con_gen) {
        $spec = $con_gen->all_attribute_specs->{$name};
      }
      $acc_gen->generate_method($target, $name, $spec);
    }
  }
  
  sub role_application_steps {
    qw(_handle_constructor _maybe_make_accessors),
      $_[0]->SUPER::role_application_steps;
  }
  
  sub apply_roles_to_package {
    my ($me, $to, @roles) = @_;
    foreach my $role (@roles) {
      _load_module($role);
      $me->_inhale_if_moose($role);
      die "${role} is not a Moo::Role" unless $me->is_role($role);
    }
    $me->SUPER::apply_roles_to_package($to, @roles);
  }
  
  sub apply_single_role_to_package {
    my ($me, $to, $role) = @_;
    _load_module($role);
    $me->_inhale_if_moose($role);
    die "${role} is not a Moo::Role" unless $me->is_role($role);
    $me->SUPER::apply_single_role_to_package($to, $role);
  }
  
  sub create_class_with_roles {
    my ($me, $superclass, @roles) = @_;
  
    my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles);
  
    return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
  
    foreach my $role (@roles) {
        _load_module($role);
        $me->_inhale_if_moose($role);
    }
  
    my $m;
    if ($INC{"Moo.pm"}
        and $m = Moo->_accessor_maker_for($superclass)
        and ref($m) ne 'Method::Generate::Accessor') {
      # old fashioned way time.
      *{_getglob("${new_name}::ISA")} = [ $superclass ];
      $Moo::MAKERS{$new_name} = {is_class => 1};
      $me->apply_roles_to_package($new_name, @roles);
      _set_loaded($new_name, (caller)[1]);
      return $new_name;
    }
  
    $me->SUPER::create_class_with_roles($superclass, @roles);
  
    foreach my $role (@roles) {
      die "${role} is not a Moo::Role" unless $me->is_role($role);
    }
  
    $Moo::MAKERS{$new_name} = {is_class => 1};
  
    $me->_handle_constructor($new_name, $_) for @roles;
  
    _set_loaded($new_name, (caller)[1]);
    return $new_name;
  }
  
  sub apply_roles_to_object {
    my ($me, $object, @roles) = @_;
    my $new = $me->SUPER::apply_roles_to_object($object, @roles);
    _set_loaded(ref $new, (caller)[1]);
  
    my $apply_defaults = $APPLY_DEFAULTS{ref $new} ||= do {
      my %attrs = map { @{$INFO{$_}{attributes}||[]} } @roles;
  
      if ($INC{'Moo.pm'}
          and keys %attrs
          and my $con_gen = Moo->_constructor_maker_for(ref $new)
          and my $m = Moo->_accessor_maker_for(ref $new)) {
        require Sub::Quote;
  
        my $specs = $con_gen->all_attribute_specs;
  
        my $assign = "{no warnings 'void';\n";
        my %captures;
        foreach my $name ( keys %attrs ) {
          my $spec = $specs->{$name};
          if ($m->has_eager_default($name, $spec)) {
            my ($has, $has_cap)
              = $m->generate_simple_has('$_[0]', $name, $spec);
            my ($code, $pop_cap)
              = $m->generate_use_default('$_[0]', $name, $spec, $has);
  
            $assign .= $code . ";\n";
            @captures{keys %$has_cap, keys %$pop_cap}
              = (values %$has_cap, values %$pop_cap);
          }
        }
        $assign .= "}";
        Sub::Quote::quote_sub($assign, \%captures);
      }
      else {
        sub {};
      }
    };
    $new->$apply_defaults;
    return $new;
  }
  
  sub _composable_package_for {
    my ($self, $role) = @_;
    my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
    return $composed_name if $Role::Tiny::COMPOSED{role}{$composed_name};
    $self->_make_accessors_if_moose($composed_name, $role);
    $self->SUPER::_composable_package_for($role);
  }
  
  sub _install_single_modifier {
    my ($me, @args) = @_;
    _install_modifier(@args);
  }
  
  sub _install_does {
      my ($me, $to) = @_;
  
      # If Role::Tiny actually installed the DOES, give it a name
      my $new = $me->SUPER::_install_does($to) or return;
      return _name_coderef("${to}::DOES", $new);
  }
  
  sub does_role {
    my ($proto, $role) = @_;
    return 1
      if Role::Tiny::does_role($proto, $role);
    my $meta;
    if ($INC{'Moose.pm'}
        and $meta = Class::MOP::class_of($proto)
        and ref $meta ne 'Moo::HandleMoose::FakeMetaClass'
        and $meta->can('does_role')
    ) {
      return $meta->does_role($role);
    }
    return 0;
  }
  
  sub _handle_constructor {
    my ($me, $to, $role) = @_;
    my $attr_info = $INFO{$role} && $INFO{$role}{attributes};
    return unless $attr_info && @$attr_info;
    my $info = $INFO{$to};
    my $con = $INC{"Moo.pm"} && Moo->_constructor_maker_for($to);
    my %existing
      = $info ? @{$info->{attributes} || []}
      : $con  ? %{$con->all_attribute_specs || {}}
      : ();
  
    my @attr_info =
      map { @{$attr_info}[$_, $_+1] }
      grep { ! $existing{$attr_info->[$_]} }
      map { 2 * $_ } 0..@$attr_info/2-1;
  
    if ($info) {
      push @{$info->{attributes}||=[]}, @attr_info;
    }
    elsif ($con) {
      # shallow copy of the specs since the constructor will assign an index
      $con->register_attribute_specs(map ref() ? { %$_ } : $_, @attr_info);
    }
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Moo::Role - Minimal Object Orientation support for Roles
  
  =head1 SYNOPSIS
  
   package My::Role;
  
   use Moo::Role;
   use strictures 2;
  
   sub foo { ... }
  
   sub bar { ... }
  
   has baz => (
     is => 'ro',
   );
  
   1;
  
  And elsewhere:
  
   package Some::Class;
  
   use Moo;
   use strictures 2;
  
   # 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 CLEANING UP IMPORTS
  
  L<Moo::Role> cleans up its own imported methods and any imports
  declared before the C<use Moo::Role> statement automatically.
  Anything imported after C<use Moo::Role> will be composed into
  consuming packages.  A package that consumes this role:
  
   package My::Role::ID;
  
   use Digest::MD5 qw(md5_hex);
   use Moo::Role;
   use Digest::SHA qw(sha1_hex);
  
   requires 'name';
  
   sub as_md5  { my ($self) = @_; return md5_hex($self->name);  }
   sub as_sha1 { my ($self) = @_; return sha1_hex($self->name); }
  
   1;
  
  ..will now have a C<< $self->sha1_hex() >> method available to it
  that probably does not do what you expect.  On the other hand, a call
  to C<< $self->md5_hex() >> will die with the helpful error message:
  C<Can't locate object method "md5_hex">.
  
  See L<Moo/"CLEANING UP IMPORTS"> for more details.
  
  =head1 SUPPORT
  
  See L<Moo> for support and contact information.
  
  =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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO__UTILS';
  package Moo::_Utils;
  
  no warnings 'once'; # guard against -w
  
  sub _getglob { \*{$_[0]} }
  sub _getstash { \%{"$_[0]::"} }
  
  use constant lt_5_8_3 => ( $] < 5.008003 or $ENV{MOO_TEST_PRE_583} ) ? 1 : 0;
  use constant can_haz_subutil => (
      $INC{"Sub/Util.pm"}
      || ( !$INC{"Sub/Name.pm"} && eval { require Sub::Util } )
    ) && defined &Sub::Util::set_subname;
  use constant can_haz_subname => (
      $INC{"Sub/Name.pm"}
      || ( !$INC{"Sub/Util.pm"} && eval { require Sub::Name } )
    ) && defined &Sub::Name::subname;
  
  use Moo::_strictures;
  use Module::Runtime qw(use_package_optimistically module_notional_filename);
  
  use Devel::GlobalDestruction ();
  use Exporter qw(import);
  use Moo::_mro;
  use Config;
  
  our @EXPORT = qw(
      _getglob _install_modifier _load_module _maybe_load_module
      _get_linear_isa _getstash _install_coderef _name_coderef
      _unimport_coderefs _in_global_destruction _set_loaded
  );
  
  sub _in_global_destruction ();
  *_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction;
  
  sub _install_modifier {
    my ($into, $type, $name, $code) = @_;
  
    if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
      require Sub::Defer;
      Sub::Defer::undefer_sub($to_modify);
    }
  
    Class::Method::Modifiers::install_modifier(@_);
  }
  
  our %MAYBE_LOADED;
  
  sub _load_module {
    my $module = $_[0];
    my $file = module_notional_filename($module);
    use_package_optimistically($module);
    return 1
      if $INC{$file};
    my $error = $@ || "Can't locate $file";
  
    # can't just ->can('can') because a sub-package Foo::Bar::Baz
    # creates a 'Baz::' key in Foo::Bar's symbol table
    my $stash = _getstash($module)||{};
    return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
    return 1
      if $INC{"Moose.pm"} && Class::MOP::class_of($module)
      or Mouse::Util->can('find_meta') && Mouse::Util::find_meta($module);
    die $error;
  }
  
  sub _maybe_load_module {
    my $module = $_[0];
    return $MAYBE_LOADED{$module}
      if exists $MAYBE_LOADED{$module};
    if(! eval { use_package_optimistically($module) }) {
      warn "$module exists but failed to load with error: $@";
    }
    elsif ( $INC{module_notional_filename($module)} ) {
      return $MAYBE_LOADED{$module} = 1;
    }
    return $MAYBE_LOADED{$module} = 0;
  }
  
  sub _set_loaded {
    $INC{Module::Runtime::module_notional_filename($_[0])} ||= $_[1];
  }
  
  sub _get_linear_isa {
    return mro::get_linear_isa($_[0]);
  }
  
  sub _install_coderef {
    my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
    no warnings 'redefine';
    if (*{$glob}{CODE}) {
      *{$glob} = $code;
    }
    # perl will sometimes warn about mismatched prototypes coming from the
    # inheritance cache, so disable them if we aren't redefining a sub
    else {
      no warnings 'prototype';
      *{$glob} = $code;
    }
  }
  
  sub _name_coderef {
    shift if @_ > 2; # three args is (target, name, sub)
    can_haz_subutil ? Sub::Util::set_subname(@_) :
      can_haz_subname ? Sub::Name::subname(@_) : $_[1];
  }
  
  sub _unimport_coderefs {
    my ($target, $info) = @_;
    return unless $info and my $exports = $info->{exports};
    my %rev = reverse %$exports;
    my $stash = _getstash($target);
    foreach my $name (keys %$exports) {
      if ($stash->{$name} and defined(&{$stash->{$name}})) {
        if ($rev{$target->can($name)}) {
          my $old = delete $stash->{$name};
          my $full_name = join('::',$target,$name);
          # Copy everything except the code slot back into place (e.g. $has)
          foreach my $type (qw(SCALAR HASH ARRAY IO)) {
            next unless defined(*{$old}{$type});
            no strict 'refs';
            *$full_name = *{$old}{$type};
          }
        }
      }
    }
  }
  
  if ($Config{useithreads}) {
    require Moo::HandleMoose::_TypeMap;
  }
  
  1;
MOO__UTILS

$fatpacked{"Moo/_mro.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO__MRO';
  package Moo::_mro;
  use Moo::_strictures;
  
  if ($] >= 5.010) {
    require mro;
  } else {
    require MRO::Compat;
  }
  
  1;
MOO__MRO

$fatpacked{"Moo/_strictures.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO__STRICTURES';
  package Moo::_strictures;
  use strict;
  use warnings;
  
  sub import {
    if ($ENV{MOO_FATAL_WARNINGS}) {
      require strictures;
      strictures->VERSION(2);
      @_ = ('strictures');
      goto &strictures::import;
    }
    else {
      strict->import;
      warnings->import;
    }
  }
  
  1;
MOO__STRICTURES

$fatpacked{"Moo/sification.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_SIFICATION';
  package Moo::sification;
  
  use Moo::_strictures;
  no warnings 'once';
  use Devel::GlobalDestruction qw(in_global_destruction);
  
  sub unimport {
    die "Can't disable Moo::sification after inflation has been done"
      if $Moo::HandleMoose::SETUP_DONE;
    our $disabled = 1;
  }
  
  sub Moo::HandleMoose::AuthorityHack::DESTROY {
    unless (our $disabled or in_global_destruction) {
      require Moo::HandleMoose;
      Moo::HandleMoose->import;
    }
  }
  
  sub import {
    return
      if our $setup_done;
    if ($INC{"Moose.pm"}) {
      require Moo::HandleMoose;
      Moo::HandleMoose->import;
    } else {
      $Moose::AUTHORITY = bless({}, 'Moo::HandleMoose::AuthorityHack');
    }
    $setup_done = 1;
  }
  
  1;
MOO_SIFICATION

$fatpacked{"Sub/Defer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_DEFER';
  package Sub::Defer;
  
  use Moo::_strictures;
  use Exporter qw(import);
  use Moo::_Utils qw(_getglob _install_coderef);
  use Scalar::Util qw(weaken);
  
  our $VERSION = '2.000002';
  $VERSION = eval $VERSION;
  
  our @EXPORT = qw(defer_sub undefer_sub undefer_all);
  our @EXPORT_OK = qw(undefer_package);
  
  our %DEFERRED;
  
  sub undefer_sub {
    my ($deferred) = @_;
    my ($target, $maker, $undeferred_ref) = @{
      $DEFERRED{$deferred}||return $deferred
    };
    return ${$undeferred_ref}
      if ${$undeferred_ref};
    ${$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';
  
      # I believe $maker already evals with the right package/name, so that
      # _install_coderef calls are not necessary --ribasushi
      *{_getglob($target)} = $made;
    }
    $DEFERRED{$made} = $DEFERRED{$deferred};
    weaken $DEFERRED{$made}
      unless $target;
  
    return $made;
  }
  
  sub undefer_all {
    undefer_sub($_) for keys %DEFERRED;
    return;
  }
  
  sub undefer_package {
    my $package = shift;
    my @subs = grep { $DEFERRED{$_}[0] =~ /^${package}::[^:]+$/ } keys %DEFERRED;
    undefer_sub($_) for @subs;
    return;
  }
  
  sub defer_info {
    my ($deferred) = @_;
    my $info = $DEFERRED{$deferred||''} or return undef;
    [ @$info ];
  }
  
  sub defer_sub {
    my ($target, $maker) = @_;
    my $undeferred;
    my $deferred_info;
    my $deferred = sub {
      $undeferred ||= undefer_sub($deferred_info->[3]);
      goto &$undeferred;
    };
    $deferred_info = [ $target, $maker, \$undeferred, $deferred ];
    weaken($deferred_info->[3]);
    weaken($DEFERRED{$deferred} = $deferred_info);
    _install_coderef($target => $deferred) if defined $target;
    return $deferred;
  }
  
  sub CLONE {
    %DEFERRED = map { defined $_ && $_->[3] ? ($_->[3] => $_) : () } values %DEFERRED;
    foreach my $info (values %DEFERRED) {
      weaken($info)
        unless $info->[0] && ${$info->[2]};
    }
  }
  
  1;
  __END__
  
  =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.
  
  Exported by default.
  
  =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>.
  
  Exported by default.
  
  =head2 undefer_all
  
   undefer_all();
  
  This will undefer all defered subs in one go.  This can be very useful in a
  forking environment where child processes would each have to undefer the same
  subs.  By calling this just before you start forking children you can undefer
  all currently deferred subs in the parent so that the children do not have to
  do it.  Note this may bake the behavior of some subs that were intended to
  calculate their behavior later, so it shouldn't be used midway through a
  module load or class definition.
  
  Exported by default.
  
  =head2 undefer_package
  
    undefer_package($package);
  
  This undefers all defered subs in a package.
  
  Not exported by default.
  
  =head1 SUPPORT
  
  See L<Moo> for support and contact information.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
  
  =cut
SUB_DEFER

$fatpacked{"Sub/Quote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_QUOTE';
  package Sub::Quote;
  
  sub _clean_eval { eval $_[0] }
  
  use Moo::_strictures;
  
  use Sub::Defer qw(defer_sub);
  use Scalar::Util qw(weaken);
  use Exporter qw(import);
  use B ();
  BEGIN {
    *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
  }
  
  our $VERSION = '2.000002';
  $VERSION = eval $VERSION;
  
  our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
  our @EXPORT_OK = qw(quotify capture_unroll inlinify);
  
  our %QUOTED;
  
  sub quotify {
    ! defined $_[0]     ? 'undef()'
    : _HAVE_PERLSTRING  ? B::perlstring($_[0])
    : qq["\Q$_[0]\E"];
  }
  
  sub capture_unroll {
    my ($from, $captures, $indent) = @_;
    join(
      '',
      map {
        /^([\@\%\$])/
          or die "capture key should start with \@, \% or \$: $_";
        (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
      } keys %$captures
    );
  }
  
  sub inlinify {
    my ($code, $args, $extra, $local) = @_;
    my $do = 'do { '.($extra||'');
    if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
      $do .= $1;
    }
    if ($code =~ s{
      \A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
      (^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
    }{}xms) {
      my ($pre, $indent, $code_args) = ($1, $2, $3);
      $do .= $pre;
      if ($code_args ne $args) {
        $do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
      }
    }
    elsif ($local || $args ne '@_') {
      $do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
    }
    $do.$code.' }';
  }
  
  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 = ref($_[-1]) eq 'HASH' ? pop : undef;
    undef($captures) if $captures && !keys %$captures;
    my $code = pop;
    my $name = $_[0];
    my ($package, $hints, $bitmask, $hintshash) = (caller(0))[0,8,9,10];
    my $context
      ="# BEGIN quote_sub PRELUDE\n"
      ."package $package;\n"
      ."BEGIN {\n"
      ."  \$^H = ".quotify($hints).";\n"
      ."  \${^WARNING_BITS} = ".quotify($bitmask).";\n"
      ."  \%^H = (\n"
      . join('', map
       "    ".quotify($_)." => ".quotify($hintshash->{$_}).",",
        keys %$hintshash)
      ."  );\n"
      ."}\n"
      ."# END quote_sub PRELUDE\n";
    $code = "$context$code";
    my $quoted_info;
    my $unquoted;
    my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
      $unquoted if 0;
      unquote_sub($quoted_info->[4]);
    };
    $quoted_info = [ $name, $code, $captures, \$unquoted, $deferred ];
    weaken($quoted_info->[3]);
    weaken($quoted_info->[4]);
    weaken($QUOTED{$deferred} = $quoted_info);
    return $deferred;
  }
  
  sub quoted_from_sub {
    my ($sub) = @_;
    my $quoted_info = $QUOTED{$sub||''} or return undef;
    my ($name, $code, $captured, $unquoted, $deferred) = @{$quoted_info};
    $unquoted &&= $$unquoted;
    if (($deferred && $deferred eq $sub)
        || ($unquoted && $unquoted eq $sub)) {
      return [ $name, $code, $captured, $unquoted, $deferred ];
    }
    return undef;
  }
  
  sub unquote_sub {
    my ($sub) = @_;
    my $quoted = $QUOTED{$sub} or return undef;
    my $unquoted = $quoted->[3];
    unless ($unquoted && $$unquoted) {
      my ($name, $code, $captures) = @$quoted;
  
      my $make_sub = "{\n";
  
      my %captures = $captures ? %$captures : ();
      $captures{'$_UNQUOTED'} = \$unquoted;
      $captures{'$_QUOTED'} = \$quoted;
      $make_sub .= capture_unroll("\$_[1]", \%captures, 2);
  
      $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"
          : "  \$\$_UNQUOTED = sub {\n"
      );
      $make_sub .= "  \$_QUOTED if 0;\n";
      $make_sub .= "  \$_UNQUOTED if 0;\n";
      $make_sub .= $code;
      $make_sub .= "  }".($name ? '' : ';')."\n";
      if ($name) {
        $make_sub .= "  \$\$_UNQUOTED = \\&${name}\n";
      }
      $make_sub .= "}\n1;\n";
      $ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
      {
        no strict 'refs';
        local *{$name} if $name;
        my ($success, $e);
        {
          local $@;
          $success = _clean_eval($make_sub, \%captures);
          $e = $@;
        }
        unless ($success) {
          die "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
        }
        weaken($QUOTED{$$unquoted} = $quoted);
      }
    }
    $$unquoted;
  }
  
  sub qsub ($) {
    goto &quote_sub;
  }
  
  sub CLONE {
    %QUOTED = map { defined $_ ? (
      $_->[3] && ${$_->[3]} ? (${ $_->[3] } => $_) : (),
      $_->[4] ? ($_->[4] => $_) : (),
    ) : () } values %QUOTED;
    weaken($_) for values %QUOTED;
  }
  
  1;
  __END__
  
  =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 = 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.  The keys should be the full name of the variable to be made available,
  including the sigil.  The values should be references to the values.  The
  variables will contain copies of the values.  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.
  
  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 '$captures', {
     '$x' => 1,
     '$y' => 2,
   }, 4;
  
   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 quotify
  
   my $quoted_value = quotify $value;
  
  Quotes a single (non-reference) scalar value for use in a code string.  Numbers
  aren't treated specially and will be quoted as strings, but undef will quoted as
  C<undef()>.
  
  =head2 capture_unroll
  
   my $prelude = capture_unroll '$captures', {
     '$x' => 1,
     '$y' => 2,
   }, 4;
  
  Arguments: $from, \%captures, $indent
  
  Generates a snippet of code which is suitable to be used as a prelude for
  L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
  code.  The keys of C<%captures> are the names of the variables and the values
  are ignored.  C<$indent> is the number of spaces to indent the result by.
  
  =head2 qsub
  
   my $hash = {
    coderef => qsub q{ print "hello"; },
    other   => 5,
   };
  
  Arguments: $code
  
  Works exactly like L</quote_sub>, but includes a prototype to only accept a
  single parameter.  This makes it easier to include in hash structures or lists.
  
  =head1 CAVEATS
  
  Much of this is just string-based code-generation, and as a result, a few
  caveats apply.
  
  =head2 return
  
  Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
  Instead of returning from the code you defined in C<quote_sub>, it will return
  from the overall function it is composited into.
  
  So when you pass in:
  
     quote_sub q{  return 1 if $condition; $morecode }
  
  It might turn up in the intended context as follows:
  
    sub foo {
  
      <important code a>
      do {
        return 1 if $condition;
        $morecode
      };
      <important code b>
  
    }
  
  Which will obviously return from foo, when all you meant to do was return from
  the code context in quote_sub and proceed with running important code b.
  
  =head2 pragmas
  
  C<Sub::Quote> preserves the environment of the code creating the
  quoted subs.  This includes the package, strict, warnings, and any
  other lexical pragmas.  This is done by prefixing the code with a
  block that sets up a matching environment.  When inlining C<Sub::Quote>
  subs, care should be taken that user pragmas won't effect the rest
  of the code.
  
  =head1 SUPPORT
  
  See L<Moo> for support and contact information.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
  
  =cut
SUB_QUOTE

$fatpacked{"Tak.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK';
  package Tak;
  
  use Tak::Loop;
  use strictures 1;
  
  our $VERSION = '0.001004'; # 0.1.4
  
  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 (then I wrote Object::Remote)
  
  =head1 SYNOPSIS
  
    # Curse at mst for doing it again under a different name
    # Curse at mst some more
    $ cpanm Object::Remote
    # Now go use that
  
  (sorry, I should've done a tombstone release ages back)
  
    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. My laptop is finally
  alive again though so I'll try and turn my slides into a vague attempt
  at documentation while I'm traveling to/from christmas things.
  
  =head1 Example
  
  $ cat Takfile
  package Tak::MyScript;
  
  use strict;
  use warnings;
  
  use Tak::Takfile;
  use Tak::ObjectClient;
  use lib "./lib";
  
  sub each_host {
      my ($self, $remote) = @_;
  
      my $oc = Tak::ObjectClient->new(remote => $remote);
      my $name = $oc->new_object('My::Hostname');
      print "Connected to hostname: " . $name . "\n";
      }
  
  1;
  
  -----
  
  $cat ./lib/My/Hostname
  package My::Hostname;
  
  use Sys::Hostname;
  
  sub new {
      my ($self) = @_;
      my $name = hostname;
      return $name;
      }
  
  1;
  
  =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 Tak 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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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 "Shere\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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_STDIONODE';
  package Tak::STDIONode;
  our $DATA = do { local $/; <DATA> };
  1;
  __DATA__
  
TAK_STDIONODE

$fatpacked{"Tak/STDIOSetup.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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 "Shere\n";
    Tak->loop_until($done);
    if (our $Next) { goto &$Next }
  }
  
  1;
TAK_STDIOSETUP

$fatpacked{"Tak/Script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALIASED';
  package aliased;
  
  our $VERSION = '0.31';
  $VERSION = eval $VERSION;
  
  require Exporter;
  @ISA    = qw(Exporter);
  @EXPORT = qw(alias prefix);
  
  use strict;
  
  sub _croak {
      require Carp;
      Carp::croak(@_);
  }
  
  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);
  
      my $destination = $alias =~ /::/
        ? $alias
        : "$callpack\::$alias";
  
      no strict 'refs';
      *{ $destination } = 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;
              _croak($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;
      return $package;
  }
  
  sub alias {
      my ( $package, @import ) = @_;
  
      my $callpack = scalar caller(0);
      return _load_alias( $package, $callpack, @import );
  }
  
  sub prefix {
      my ($class) = @_;
      return sub {
          my ($name) = @_;
          my $callpack = caller(0);
          if ( not @_ ) {
              return _load_alias( $class, $callpack );
          }
          elsif ( @_ == 1 && defined $name ) {
              return _load_alias( "${class}::$name", $callpack );
          }
          else {
              _croak("Too many arguments to prefix('$class')");
          }
      };
  }
  
  1;
  __END__
  
  =head1 NAME
  
  aliased - Use shorter versions of class names.
  
  =head1 VERSION
  
  0.31
  
  =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()
  
  This function is only exported if you specify C<use aliased> with no import
  list.
  
      use aliased;
      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 prefix() (experimental)
  
  This function is only exported if you specify C<use aliased> with no import
  list.
  
      use aliased;
  
  Sometimes you find you have a ton of packages in the same top-level namespace
  and you want to alias them, but only use them on demand.  For example:
  
      # instead of:
      MailVerwaltung::Client::Exception::REST::Response->throw()
  
      my $error = prefix('MailVerwaltung::Client::Exception');
      $error->('REST::Response')->throw();   # same as above
      $error->()->throw; # same as MailVerwaltung::Client::Exception->throw
  
  =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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'OO';
  package oo;
  
  use Moo::_strictures;
  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;
  __END__
  
  =head1 NAME
  
  oo - syntactic sugar for Moo oneliners
  
  =head1 SYNOPSIS
  
    perl -Moo=Foo -e 'has bar => ( is => q[ro], default => q[baz] ); print Foo->new->bar'
  
    # loads an existing class and re-"opens" the package definition
    perl -Moo=+My::Class -e 'print __PACKAGE__->new->bar'
  
  =head1 DESCRIPTION
  
  oo.pm is a simple source filter that adds C<package $name; use Moo;> to the
  beginning of your script, intended for use on the command line via the -M
  option.
  
  =head1 SUPPORT
  
  See L<Moo> for support and contact information.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
  
  =cut
OO

$fatpacked{"strictures.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRICTURES';
  package strictures;
  
  use strict;
  use warnings FATAL => 'all';
  
  BEGIN {
    *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0};
    *_CAN_GOTO_VERSION = ($] >= 5.008000) ? sub(){1} : sub(){0};
  }
  
  our $VERSION = '2.000000';
  $VERSION = eval $VERSION;
  
  our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
    closure
    chmod
    deprecated
    exiting
    experimental
      experimental::autoderef
      experimental::const_attr
      experimental::lexical_subs
      experimental::lexical_topic
      experimental::postderef
      experimental::re_strict
      experimental::refaliasing
      experimental::regex_sets
      experimental::signatures
      experimental::smartmatch
      experimental::win32_perlio
    glob
    imprecision
    io
      closed
      exec
      layer
      newline
      pipe
      syscalls
      unopened
    locale
    misc
    missing
    numeric
    once
    overflow
    pack
    portable
    recursion
    redefine
    redundant
    regexp
    severe
      debugging
      inplace
      internal
      malloc
    signal
    substr
    syntax
      ambiguous
      bareword
      digit
      illegalproto
      parenthesis
      precedence
      printf
      prototype
      qw
      reserved
      semicolon
    taint
    threads
    uninitialized
    umask
    unpack
    untie
    utf8
      non_unicode
      nonchar
      surrogate
    void
    void_unusual
    y2k
  );
  
  sub VERSION {
    {
      no warnings;
      local $@;
      if (defined $_[1] && eval { &UNIVERSAL::VERSION; 1}) {
        $^H |= 0x20000
          unless _PERL_LT_5_8_4;
        $^H{strictures_enable} = int $_[1];
      }
    }
    _CAN_GOTO_VERSION ? goto &UNIVERSAL::VERSION : &UNIVERSAL::VERSION;
  }
  
  our %extra_load_states;
  
  our $Smells_Like_VCS;
  
  sub import {
    my $class = shift;
    my %opts = ref $_[0] ? %{$_[0]} : @_;
    if (!exists $opts{version}) {
      $opts{version}
        = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
        : int $VERSION;
    }
    $opts{file} = (caller)[1];
    $class->_enable(\%opts);
  }
  
  sub _enable {
    my ($class, $opts) = @_;
    my $version = $opts->{version};
    $version = 'undef'
      if !defined $version;
    my $method = "_enable_$version";
    if (!$class->can($method)) {
      require Carp;
      Carp::croak("Major version specified as $version - not supported!");
    }
    $class->$method($opts);
  }
  
  sub _enable_1 {
    my ($class, $opts) = @_;
    strict->import;
    warnings->import(FATAL => 'all');
  
    if (_want_extra($opts->{file})) {
      _load_extras(qw(indirect multidimensional bareword::filehandles));
      indirect->unimport(':fatal')
        if $extra_load_states{indirect};
      multidimensional->unimport
        if $extra_load_states{multidimensional};
      bareword::filehandles->unimport
        if $extra_load_states{'bareword::filehandles'};
    }
  }
  
  our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } (
    'exec',         # not safe to catch
    'recursion',    # will be caught by other mechanisms
    'internal',     # not safe to catch
    'malloc',       # not safe to catch
    'newline',      # stat on nonexistent file with a newline in it
    'experimental', # no reason for these to be fatal
    'deprecated',   # unfortunately can't make these fatal
    'portable',     # everything worked fine here, just may not elsewhere
  );
  our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
    'once'          # triggers inconsistently, can't be fatalized
  );
  
  sub _enable_2 {
    my ($class, $opts) = @_;
    strict->import;
    warnings->import;
    warnings->import(FATAL => @WARNING_CATEGORIES);
    warnings->unimport(FATAL => @V2_NONFATAL);
    warnings->import(@V2_NONFATAL);
    warnings->unimport(@V2_DISABLE);
  
    if (_want_extra($opts->{file})) {
      _load_extras(qw(indirect multidimensional bareword::filehandles));
      indirect->unimport(':fatal')
        if $extra_load_states{indirect};
      multidimensional->unimport
        if $extra_load_states{multidimensional};
      bareword::filehandles->unimport
        if $extra_load_states{'bareword::filehandles'};
    }
  }
  
  sub _want_extra_env {
    if (exists $ENV{PERL_STRICTURES_EXTRA}) {
      if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
        die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
          . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
      }
      return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
    }
    return undef;
  }
  
  sub _want_extra {
    my $file = shift;
    my $want_env = _want_extra_env();
    return $want_env
      if defined $want_env;
    return (
      !_PERL_LT_5_8_4
      and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
      and defined $Smells_Like_VCS ? $Smells_Like_VCS
        : ( $Smells_Like_VCS = !!(
          -e '.git' || -e '.svn' || -e '.hg'
          || (-e '../../dist.ini'
            && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
        ))
    );
  }
  
  sub _load_extras {
    my @extras = @_;
    my @failed;
    foreach my $mod (@extras) {
      next
        if exists $extra_load_states{$mod};
  
      $extra_load_states{$mod} = eval "require $mod; 1;" or do {
        push @failed, $mod;
  
        #work around 5.8 require bug
        (my $file = $mod) =~ s|::|/|g;
        delete $INC{"${file}.pm"};
      };
    }
  
    if (@failed) {
      my $failed = join ' ', @failed;
      my $extras = join ' ', @extras;
      print STDERR <<EOE;
  strictures.pm extra testing active but couldn't load all modules. Missing were:
  
    $failed
  
  Extra testing is auto-enabled in checkouts only, so if you're the author
  of a strictures-using module you need to run:
  
    cpan $extras
  
  but these modules are not required by your users.
  EOE
    }
  }
  
  1;
  
  __END__
  =head1 NAME
  
  strictures - turn on strict and make all warnings fatal
  
  =head1 SYNOPSIS
  
    use strictures 2;
  
  is equivalent to
  
    use strict;
    use warnings FATAL => 'all';
    use warnings NONFATAL => qw(
      exec
      recursion
      internal
      malloc
      newline
      experimental
      deprecated
      portable
    );
    no warnings 'once';
  
  except when called from a file which matches:
  
    (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
  
  and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory
  (with the intention of only forcing extra tests on the author side) -- or when
  C<.git>, C<.svn>, or C<.hg> is present two directories up along with
  C<dist.ini> (which would indicate we are in a C<dzil test> operation, via
  L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable is
  set, in which case it also does the equivalent of
  
    no indirect 'fatal';
    no multidimensional;
    no bareword::filehandles;
  
  Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
  only a minor version increase, but any changes to the effect of C<use
  strictures> in normal mode will involve a major version bump.
  
  If any of the extra testing modules are not present, L<strictures> will
  complain loudly, once, via C<warn()>, and then shut up. But you really
  should consider installing them, they're all great anti-footgun tools.
  
  =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 C<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, L<strictures> turns on additional checking, but only when it thinks
  it's running in a test file in a VCS checkout -- although if this causes
  undesired behaviour this can be overridden by setting the
  C<PERL_STRICTURES_EXTRA> environment variable.
  
  If additional useful author side checks come to mind, I'll add them to the
  C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
  increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
  mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
  1.000001 (1.0.1)).
  
  =head1 CATEGORY SELECTIONS
  
  strictures does not enable fatal warnings for all categories.
  
  =over 4
  
  =item exec
  
  Includes a warning that can cause your program to continue running
  unintentionally after an internal fork.  Not safe to fatalize.
  
  =item recursion
  
  Infinite recursion will end up overflowing the stack eventually anyway.
  
  =item internal
  
  Triggers deep within perl, in places that are not safe to trap.
  
  =item malloc
  
  Triggers deep within perl, in places that are not safe to trap.
  
  =item newline
  
  Includes a warning for using stat on a valid but suspect filename, ending in a
  newline.
  
  =item experimental
  
  Experimental features are used intentionally.
  
  =item deprecated
  
  Deprecations will inherently be added to in the future in unexpected ways,
  so making them fatal won't be reliable.
  
  =item portable
  
  Doesn't indicate an actual problem with the program, only that it may not
  behave properly if run on a different machine.
  
  =item once
  
  Can't be fatalized.  Also triggers very inconsistently, so we just disable it.
  
  =back
  
  =head1 VERSIONS
  
  Depending on the version of strictures requested, different warnings will be
  enabled.  If no specific version is requested, the current version's behavior
  will be used.  Versions can be requested using perl's standard mechanism:
  
    use strictures 2;
  
  Or, by passing in a C<version> option:
  
    use strictures version => 2;
  
  =head2 VERSION 2
  
  Equivalent to:
  
    use strict;
    use warnings FATAL => 'all';
    use warnings NONFATAL => qw(
      exec
      recursion
      internal
      malloc
      newline
      experimental
      deprecated
      portable
    );
    no warnings 'once';
  
    # and if in dev mode:
    no indirect 'fatal';
    no multidimensional;
    no bareword::filehandles;
  
  Additionally, any warnings created by modules using L<warnings::register> or
  C<warnings::register_categories()> will not be fatalized.
  
  =head2 VERSION 1
  
  Equivalent to:
  
    use strict;
    use warnings FATAL => 'all';
    # and if in dev mode:
    no indirect 'fatal';
    no multidimensional;
    no bareword::filehandles;
  
  =head1 METHODS
  
  =head2 import
  
  This method does the setup work described above in L</DESCRIPTION>.  Optionally
  accepts a C<version> option to request a specific version's behavior.
  
  =head2 VERSION
  
  This method traps the C<< strictures->VERSION(1) >> call produced by a use line
  with a version number on it and does the version check.
  
  =head1 EXTRA TESTING RATIONALE
  
  Every so often, somebody complains that they're deploying via C<git pull>
  and that they don't want L<strictures> to enable itself in this case -- and that
  setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
  disable extra testing would be welcome but the discussion never seems to get
  that far).
  
  In order to allow us to skip a couple of stages and get straight to a
  productive conversation, here's my current rationale for turning the
  extra testing on via a heuristic:
  
  The extra testing is all stuff that only ever blows up at compile time;
  this is intentional. So the oft-raised concern that it's different code being
  tested is only sort of the case -- none of the modules involved affect the
  final optree to my knowledge, so the author gets some additional compile
  time crashes which he/she then fixes, and the rest of the testing is
  completely valid for all environments.
  
  The point of the extra testing -- especially C<no indirect> -- is to catch
  mistakes that newbie users won't even realise are mistakes without
  help. For example,
  
    foo { ... };
  
  where foo is an & prototyped sub that you forgot to import -- this is
  pernicious to track down since all I<seems> fine until it gets called
  and you get a crash. Worse still, you can fail to have imported it due
  to a circular require, at which point you have a load order dependent
  bug which I've seen before now I<only> show up in production due to tiny
  differences between the production and the development environment. I wrote
  L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
  this particular problem before L<strictures> itself existed.
  
  As such, in my experience so far L<strictures>' extra testing has
  I<avoided> production versus development differences, not caused them.
  
  Additionally, L<strictures>' policy is very much "try and provide as much
  protection as possible for newbies -- who won't think about whether there's
  an option to turn on or not" -- so having only the environment variable
  is not sufficient to achieve that (I get to explain that you need to add
  C<use strict> at least once a week on freenode #perl -- newbies sometimes
  completely skip steps because they don't understand that that step
  is important).
  
  I make no claims that the heuristic is perfect -- it's already been evolved
  significantly over time, especially for 1.004 where we changed things to
  ensure it only fires on files in your checkout (rather than L<strictures>-using
  modules you happened to have installed, which was just silly). However, I
  hope the above clarifies why a heuristic approach is not only necessary but
  desirable from a point of view of providing new users with as much safety as
  possible, and will allow any future discussion on the subject to focus on "how
  do we minimise annoyance to people deploying from checkouts intentionally".
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<indirect>
  
  =item *
  
  L<multidimensional>
  
  =item *
  
  L<bareword::filehandles>
  
  =back
  
  =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
  
  The web interface to the repository is at:
  
    http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  Karen Etheridge (cpan:ETHER) <ether@cpan.org>
  
  Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
  
  haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
  
  =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

$fatpacked{"strictures/extra.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRICTURES_EXTRA';
  package strictures::extra;
  use strict;
  use warnings FATAL => 'all';
  
  sub import {
    $ENV{PERL_STRICTURES_EXTRA} = 1;
  }
  
  sub unimport {
    $ENV{PERL_STRICTURES_EXTRA} = 0;
  }
  
  1;
  
  __END__
  =head1 NAME
  
  strictures::extra - enable or disable strictures additional checks
  
  =head1 SYNOPSIS
  
    no strictures::extra;
    # will not enable indirect, multidimensional, or bareword filehandle checks
    use strictures;
  
  =head1 DESCRIPTION
  
  Enable or disable strictures additional checks, preventing checks for C<.git>
  or other VCS directories.
  
  Equivalent to setting the C<PERL_STRICTURES_EXTRA> environment variable.
  
  =head1 AUTHORS
  
  See L<strictures> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<strictures> for the copyright and license.
  
  =cut
STRICTURES_EXTRA

s/^  //mg for values %fatpacked;

my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
     if (my $fat = $_[0]{$_[1]}) {
       return sub {
         return 0 unless length $fat;
         $fat =~ s/^([^\n]*\n?)//;
         $_ = $1;
         return 1;
       };
     }
     return;
  };
}

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

unshift @INC, bless \%fatpacked, $class;
  } # END OF FATPACK CODE

#!/usr/bin/env perl

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