#!/usr/bin/perl

use strict;
use Config;
BEGIN {
    my @oldinc = @INC;
    @INC = ( $Config{sitelibexp}."/".$Config{archname}, $Config{sitelibexp}, @Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>} );
    require Cwd;
    @INC = @oldinc;
}


# 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{"App/Perlbrew/HTTP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_HTTP';
  package App::Perlbrew::HTTP;
  use strict;
  use warnings;
  use 5.008;
  
  use Exporter 'import';
  our @EXPORT_OK = qw(http_user_agent_program http_user_agent_command http_get http_download);
  
  our $HTTP_VERBOSE = 0;
  our $HTTP_USER_AGENT_PROGRAM;
  
  my %commands = (
      curl => {
          test     => '--version >/dev/null 2>&1',
          get      => '--silent --location --fail -o - {url}',
          download => '--silent --location --fail -o {output} {url}',
          order    => 1,
  
          # Exit code is 22 on 404s etc
          die_on_error => sub { die 'Page not retrieved; HTTP error code 400 or above.' if ($_[ 0 ] >> 8 == 22); },
      },
      wget => {
          test     => '--version >/dev/null 2>&1',
          get      => '--quiet -O - {url}',
          download => '--quiet -O {output} {url}',
          order    => 2,
  
          # Exit code is not 0 on error
          die_on_error => sub { die 'Page not retrieved: fetch failed.' if ($_[ 0 ]); },
      },
      fetch => {
          test     => '--version >/dev/null 2>&1',
          get      => '-o - {url}',
          download => '-o {output} {url}',
          order    => 3,
  
          # Exit code is 8 on 404s etc
          die_on_error => sub { die 'Server issued an error response.' if ($_[ 0 ] >> 8 == 8); },
      }
  );
  
  sub http_user_agent_program {
      $HTTP_USER_AGENT_PROGRAM ||= do {
          my $program;
  
          for my $p (sort {$commands{$a}{order}<=>$commands{$b}{order}} keys %commands) {
              my $code = system("$p $commands{$p}->{test}") >> 8;
              if ($code != 127) {
                  $program = $p;
                  last;
              }
          }
  
          unless ($program) {
              die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n";
          }
  
          $program;
      };
  
      die "[ERROR] Unrecognized http user agent program: $HTTP_USER_AGENT_PROGRAM. It can only be one of: ".join(",", keys %commands)."\n" unless $commands{$HTTP_USER_AGENT_PROGRAM};
  
      return $HTTP_USER_AGENT_PROGRAM;
  }
  
  sub http_user_agent_command {
      my ($purpose, $params) = @_;
      my $ua = http_user_agent_program;
      my $cmd = $commands{ $ua }->{ $purpose };
      for (keys %$params) {
          $cmd =~ s!{$_}!\Q$params->{$_}\E!g;
      }
  
      if ($HTTP_VERBOSE) {
          unless ($ua eq "fetch") {
              $cmd =~ s/(silent|quiet)/verbose/;
          }
      }
  
      $cmd = $ua . " " . $cmd;
      return ($ua, $cmd) if wantarray;
      return $cmd;
  }
  
  sub http_download {
      my ($url, $path) = @_;
  
      if (-e $path) {
          die "ERROR: The download target < $path > already exists.\n";
      }
  
      my $partial = 0;
      local $SIG{TERM} = local $SIG{INT} = sub { $partial++ };
  
      my $download_command = http_user_agent_command(download => { url => $url, output => $path });
  
      my $status = system($download_command);
      if ($partial) {
          $path->unlink;
          return "ERROR: Interrupted.";
      }
      unless ($status == 0) {
          $path->unlink;
          if ($? == -1) {
              return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$!";
          }
          elsif ($? & 127) {
              return "ERROR: The command died with signal " . ($? & 127) . "\n\n\t$download_command\n\n";
          }
          else {
              return "ERROR: The command finished with error\n\n\t$download_command\n\nExit code:\n\n\t" . ($? >> 8);
          }
      }
      return 0;
  }
  
  sub http_get {
      my ($url, $header, $cb) = @_;
  
      if (ref($header) eq 'CODE') {
          $cb = $header;
          $header = undef;
      }
  
      my ($program, $command) = http_user_agent_command(get => { url =>  $url });
  
      open my $fh, '-|', $command
      or die "open() pipe for '$command': $!";
  
      local $/;
      my $body = <$fh>;
      close $fh;
  
      # check if the download has failed and die automatically
      $commands{ $program }{ die_on_error }->($?);
  
      return $cb ? $cb->($body) : $body;
  }
  
  1;
APP_PERLBREW_HTTP

$fatpacked{"App/Perlbrew/Path.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH';
  use strict;
  use warnings;
  
  package App::Perlbrew::Path;
  
  use File::Basename ();
  use File::Glob ();
  use File::Path ();
  
  use overload (
      '""' => \& stringify,
      fallback => 1,
  );
  
  sub _joinpath {
      for my $entry (@_) {
          no warnings 'uninitialized';
          die 'Received an undefined entry as a parameter (all parameters are: '. join(', ', @_). ')' unless (defined($entry));
      }
      return join "/", @_;
  }
  
  sub _child {
      my ($self, $package, @path) = @_;
  
      $package->new($self->{path}, @path);
  }
  
  sub _children {
      my ($self, $package) = @_;
  
      map { $package->new($_) } File::Glob::bsd_glob($self->child("*"));
  }
  
  sub new {
      my ($class, @path) = @_;
  
      bless { path => _joinpath (@path) }, $class;
  }
  
  sub exists {
      my ($self) = @_;
  
      -e $self->stringify;
  }
  
  sub basename {
      my ($self, $suffix) = @_;
  
      return scalar File::Basename::fileparse($self, ($suffix) x!! defined $suffix);
  }
  
  sub child {
      my ($self, @path) = @_;
  
      return $self->_child(__PACKAGE__, @path);
  }
  
  sub children {
      my ($self) = @_;
  
      return $self->_children(__PACKAGE__);
  }
  
  sub dirname {
      my ($self) = @_;
  
      return App::Perlbrew::Path->new( File::Basename::dirname($self) );
  }
  
  sub mkpath {
      my ($self) = @_;
      File::Path::mkpath( [$self->stringify], 0, 0777 );
      return $self;
  }
  
  sub readlink {
      my ($self) = @_;
  
      my $link = CORE::readlink( $self->stringify );
      $link = __PACKAGE__->new($link) if defined $link;
  
      return $link;
  }
  
  sub rmpath {
      my ($self) = @_;
      File::Path::rmtree( [$self->stringify], 0, 0 );
      return $self;
  }
  
  sub stringify {
      my ($self) = @_;
  
      return $self->{path};
  }
  
  sub stringify_with_tilde {
      my ($self) = @_;
      my $path = $self->stringify;
      my $home = $ENV{HOME};
      $path =~ s!\Q$home/\E!~/! if $home;
      return $path;
  }
  
  sub symlink {
      my ($self, $destination, $force) = @_;
      $destination = App::Perlbrew::Path->new($destination) unless ref $destination;
  
      CORE::unlink($destination) if $force && (-e $destination || -l $destination);
  
      $destination if CORE::symlink($self, $destination);
  }
  
  sub unlink {
      my ($self) = @_;
      CORE::unlink($self);
  }
  
  1;
  
APP_PERLBREW_PATH

$fatpacked{"App/Perlbrew/Path/Installation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_INSTALLATION';
  use strict;
  use warnings;
  
  package App::Perlbrew::Path::Installation;
  
  require App::Perlbrew::Path;
  
  our @ISA = qw( App::Perlbrew::Path );
  
  sub name {
      $_[0]->basename;
  }
  
  sub bin {
      shift->child(bin => @_);
  }
  
  sub man {
      shift->child(man => @_);
  }
  
  sub perl {
      shift->bin('perl');
  }
  
  sub version_file {
      shift->child('.version');
  }
  
  1;
  
APP_PERLBREW_PATH_INSTALLATION

$fatpacked{"App/Perlbrew/Path/Installations.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_INSTALLATIONS';
  use strict;
  use warnings;
  
  package App::Perlbrew::Path::Installations;
  
  require App::Perlbrew::Path;
  require App::Perlbrew::Path::Installation;
  
  our @ISA = qw( App::Perlbrew::Path );
  
  sub child {
      my ($self, @params) = @_;
  
      my $return = $self;
      $return = $return->_child('App::Perlbrew::Path::Installation' => shift @params) if @params;
      $return = $return->child(@params) if @params;
  
      $return;
  }
  
  sub children {
      shift->_children('App::Perlbrew::Path::Installation' => @_);
  }
  
  sub list {
      shift->children;
  }
  
  1;
  
APP_PERLBREW_PATH_INSTALLATIONS

$fatpacked{"App/Perlbrew/Path/Root.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_ROOT';
  use strict;
  use warnings;
  
  package App::Perlbrew::Path::Root;
  
  use App::Perlbrew::Path ();
  use App::Perlbrew::Path::Installations ();
  
  our @ISA = qw( App::Perlbrew::Path );
  
  sub bin {
      shift->child(bin => @_);
  }
  
  sub build {
      shift->child(build => @_);
  }
  
  sub dists {
      shift->child(dists => @_);
  }
  
  sub etc {
      shift->child(etc => @_);
  }
  
  sub perls {
      my ($self, @params) = @_;
  
      my $return = $self->_child('App::Perlbrew::Path::Installations', 'perls');
      $return = $return->child(@params) if @params;
  
      return $return;
  }
  
  1;
  
APP_PERLBREW_PATH_ROOT

$fatpacked{"App/Perlbrew/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_UTIL';
  package App::Perlbrew::Util;
  use strict;
  use warnings;
  use 5.008;
  
  use Exporter 'import';
  our @EXPORT = qw( uniq min editdist files_are_the_same perl_version_to_integer );
  our @EXPORT_OK = qw( find_similar_tokens );
  
  sub uniq {
      my %seen;
      grep { !$seen{$_}++ } @_;
  }
  
  sub min(@) {
      my $m = $_[0];
      for(@_) {
          $m = $_ if $_ < $m;
      }
      return $m;
  }
  
  # straight copy of Wikipedia's "Levenshtein Distance"
  sub editdist {
      my @a = split //, shift;
      my @b = split //, shift;
  
      # There is an extra row and column in the matrix. This is the
      # distance from the empty string to a substring of the target.
      my @d;
      $d[$_][0] = $_ for (0 .. @a);
      $d[0][$_] = $_ for (0 .. @b);
  
      for my $i (1 .. @a) {
          for my $j (1 .. @b) {
              $d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1]
                  : 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1]));
          }
      }
  
      return $d[@a][@b];
  }
  
  sub files_are_the_same {
      ## Check dev and inode num. Not useful on Win32.
      ## The for loop should always return false on Win32, as a result.
  
      my @files = @_;
      my @stats = map {[ stat($_) ]} @files;
  
      my $stats0 = join " ", @{$stats[0]}[0,1];
      for (@stats) {
          return 0 if ((! defined($_->[1])) || $_->[1] == 0);
          unless ($stats0 eq join(" ", $_->[0], $_->[1])) {
              return 0;
          }
      }
      return 1
  }
  
  sub perl_version_to_integer {
      my $version = shift;
  
      my @v;
      if ($version eq 'blead') {
          @v = (999,999,999);
      } else {
          @v = split(/[\.\-_]/, $version);
      }
      return undef if @v < 2;
  
      if ($v[1] <= 5) {
          $v[2] ||= 0;
          $v[3] = 0;
      }
      else {
          $v[3] ||= $v[1] >= 6 ? 9 : 0;
          $v[3] =~ s/[^0-9]//g;
      }
  
      return $v[1]*1000000 + $v[2]*1000 + $v[3];
  }
  
  sub find_similar_tokens {
      my ($token, $tokens) = @_;
      my $SIMILAR_DISTANCE = 6;
  
      my @similar_tokens = sort { $a->[1] <=> $b->[1] } map {
          my $d = editdist( $_, $token );
          ( ( $d < $SIMILAR_DISTANCE ) ? [$_, $d] : () )
      } @$tokens;
  
      if (@similar_tokens) {
          my $best_score = $similar_tokens[0][1];
          @similar_tokens = map { $_->[0] } grep { $_->[1] == $best_score } @similar_tokens;
      }
  
      return \@similar_tokens;
  }
  
  1;
APP_PERLBREW_UTIL

$fatpacked{"App/perlbrew.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW';
  package App::perlbrew;
  use strict;
  use warnings;
  use 5.008;
  our $VERSION = "0.98";
  use Config qw( %Config );
  
  BEGIN {
      # Special treat for Cwd to prevent it to be loaded from somewhere binary-incompatible with system perl.
      my @oldinc = @INC;
  
      @INC = (
          $Config{sitelibexp} . "/" . $Config{archname},
          $Config{sitelibexp}, @Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>},
      );
  
      require Cwd;
      @INC = @oldinc;
  }
  
  use Getopt::Long ();
  use CPAN::Perl::Releases ();
  use JSON::PP qw( decode_json );
  use File::Copy qw( copy );
  use Capture::Tiny ();
  
  use App::Perlbrew::Util qw( files_are_the_same uniq find_similar_tokens );
  use App::Perlbrew::Path ();
  use App::Perlbrew::Path::Root ();
  use App::Perlbrew::HTTP qw( http_download http_get );
  
  ### global variables
  
  # set $ENV{SHELL} to executable path of parent process (= shell) if it's missing
  # (e.g. if this script was executed by a daemon started with "service xxx start")
  # ref: https://github.com/gugod/App-perlbrew/pull/404
  $ENV{SHELL} ||= App::Perlbrew::Path->new( "/proc", getppid, "exe" )->readlink if -d "/proc";
  
  local $SIG{__DIE__} = sub {
      my $message = shift;
      warn $message;
      exit(1);
  };
  
  our $CONFIG;
  our $PERLBREW_ROOT;
  our $PERLBREW_HOME;
  
  my @flavors = (
      {
          d_option => 'usethreads',
          implies  => 'multi',
          common   => 1,
          opt      => 'thread|threads'
      },    # threads is for backward compatibility
  
      {
          d_option => 'usemultiplicity',
          opt      => 'multi'
      },
  
      {
          d_option => 'uselongdouble',
          common   => 1,
          opt      => 'ld'
      },
  
      {
          d_option => 'use64bitint',
          common   => 1,
          opt      => '64int'
      },
  
      {
          d_option => 'use64bitall',
          implies  => '64int',
          opt      => '64all'
      },
  
      {
          d_option => 'DEBUGGING',
          opt      => 'debug'
      },
  
      {
          d_option => 'cc=clang',
          opt      => 'clang'
      },
  );
  
  my %flavor;
  my $flavor_ix = 0;
  for (@flavors) {
      my ($name) = $_->{opt} =~ /([^|]+)/;
      $_->{name}     = $name;
      $_->{ix}       = ++$flavor_ix;
      $flavor{$name} = $_;
  }
  for (@flavors) {
      if ( my $implies = $_->{implies} ) {
          $flavor{$implies}{implied_by} = $_->{name};
      }
  }
  
  ### methods
  sub new {
      my ( $class, @argv ) = @_;
  
      my %opt = (
          original_argv => \@argv,
          args          => [],
          yes           => 0,
          force         => 0,
          quiet         => 0,
          D             => [],
          U             => [],
          A             => [],
          sitecustomize => '',
          destdir       => '',
          noman         => '',
          variation     => '',
          both          => [],
          append        => '',
          reverse       => 0,
          verbose       => 0,
      );
  
      $opt{$_} = '' for keys %flavor;
  
      if (@argv) {
  
          # build a local @ARGV to allow us to use an older
          # Getopt::Long API in case we are building on an older system
          local (@ARGV) = @argv;
  
          Getopt::Long::Configure(
              'pass_through',
              'no_ignore_case',
              'bundling',
              'permute',    # default behaviour except 'exec'
          );
  
          $class->parse_cmdline( \%opt );
  
          $opt{args} = \@ARGV;
  
          # fix up the effect of 'bundling'
          foreach my $flags ( @opt{qw(D U A)} ) {
              foreach my $value ( @{$flags} ) {
                  $value =~ s/^=//;
              }
          }
      }
  
      my $self = bless \%opt, $class;
  
      # Treat --root option same way as env variable PERLBREW_ROOT (with higher priority)
      if ( $opt{root} ) {
          $ENV{PERLBREW_ROOT} = $self->root( $opt{root} );
      }
  
      if ( $opt{builddir} ) {
          $self->{builddir} = App::Perlbrew::Path->new( $opt{builddir} );
      }
  
      # Ensure propagation of $PERLBREW_HOME and $PERLBREW_ROOT
      $self->root;
      $self->home;
  
      if ( $self->{verbose} ) {
          $App::Perlbrew::HTTP::HTTP_VERBOSE = 1;
      }
  
      return $self;
  }
  
  sub parse_cmdline {
      my ( $self, $params, @ext ) = @_;
  
      my @f = map { $flavor{$_}{opt} || $_ } keys %flavor;
  
      return Getopt::Long::GetOptions(
          $params,
  
          'yes',
          'force|f',
          'reverse',
          'notest|n',
          'quiet|q',
          'verbose|v',
          'output|o=s',
          'as=s',
          'append=s',
          'help|h',
          'version',
          'root=s',
          'switch',
          'all',
          'shell=s',
          'no-patchperl',
          'no-decoration',
  
          "builddir=s",
  
          # options passed directly to Configure
          'D=s@',
          'U=s@',
          'A=s@',
  
          'j=i',
  
          # options that affect Configure and customize post-build
          'sitecustomize=s',
          'destdir=s',
          'noman',
  
          # flavors support
          'both|b=s@',
          'all-variations',
          'common-variations',
          @f,
  
          @ext
      );
  }
  
  sub root {
      my ( $self, $new_root ) = @_;
  
      $new_root ||=
             $PERLBREW_ROOT
          || $ENV{PERLBREW_ROOT}
          || App::Perlbrew::Path->new( $ENV{HOME}, "perl5", "perlbrew" )->stringify
          unless $self->{root};
  
      $self->{root} = $PERLBREW_ROOT = $new_root
          if defined $new_root;
  
      $self->{root} = App::Perlbrew::Path::Root->new( $self->{root} )
          unless ref $self->{root};
  
      $self->{root} = App::Perlbrew::Path::Root->new( $self->{root}->stringify )
          unless $self->{root}->isa('App::Perlbrew::Path::Root');
  
      return $self->{root};
  }
  
  sub home {
      my ( $self, $new_home ) = @_;
  
      $new_home ||=
             $PERLBREW_HOME
          || $ENV{PERLBREW_HOME}
          || App::Perlbrew::Path->new( $ENV{HOME}, ".perlbrew" )->stringify
          unless $self->{home};
  
      $self->{home} = $PERLBREW_HOME = $new_home
          if defined $new_home;
  
      $self->{home} = App::Perlbrew::Path->new( $self->{home} )
          unless ref $self->{home};
  
      return $self->{home};
  }
  
  sub builddir {
      my ($self) = @_;
  
      return $self->{builddir} || $self->root->build;
  }
  
  sub current_perl {
      my ( $self, $v ) = @_;
      $self->{current_perl} = $v if $v;
      return $self->{current_perl} || $self->env('PERLBREW_PERL') || '';
  }
  
  sub current_lib {
      my ( $self, $v ) = @_;
      $self->{current_lib} = $v if $v;
      return $self->{current_lib} || $self->env('PERLBREW_LIB') || '';
  }
  
  sub current_shell_is_bashish {
      my ($self) = @_;
      return ( $self->current_shell eq 'bash' ) || ( $self->current_shell eq 'zsh' );
  }
  
  sub current_shell {
      my ( $self, $x ) = @_;
      $self->{current_shell} = $x if $x;
      return $self->{current_shell} ||= do {
          my $shell_name = App::Perlbrew::Path->new( $self->{shell} || $self->env('SHELL') )->basename;
          $shell_name =~ s/\d+$//;
          $shell_name;
      };
  }
  
  sub current_env {
      my ($self) = @_;
      my $l = $self->current_lib;
      $l = "@" . $l if $l;
      return $self->current_perl . $l;
  }
  
  sub installed_perl_executable {
      my ( $self, $name ) = @_;
      die unless $name;
  
      my $executable = $self->root->perls($name)->perl;
      return $executable if -e $executable;
      return "";
  }
  
  sub configure_args {
      my ( $self, $name ) = @_;
  
      my $perl_cmd = $self->installed_perl_executable($name);
      my $code     = 'while(($_,$v)=each(%Config)){print"$_ $v" if /config_arg/}';
  
      my @output = split "\n" => $self->do_capture( $perl_cmd, '-MConfig', '-wle', $code );
  
      my %arg;
      for (@output) {
          my ( $k, $v ) = split " ", $_, 2;
          $arg{$k} = $v;
      }
  
      if (wantarray) {
          return map { $arg{"config_arg$_"} } ( 1 .. $arg{config_argc} );
      }
  
      return $arg{config_args};
  }
  
  sub cpan_mirror {
      my ( $self, $v ) = @_;
  
      $self->{cpan_mirror} = $v if $v;
  
      unless ( $self->{cpan_mirror} ) {
          $self->{cpan_mirror} = $self->env("PERLBREW_CPAN_MIRROR") || "https://cpan.metacpan.org";
          $self->{cpan_mirror} =~ s{/+$}{};
      }
  
      return $self->{cpan_mirror};
  }
  
  sub env {
      my ( $self, $name ) = @_;
      return $ENV{$name} if $name;
      return \%ENV;
  }
  
  sub is_shell_csh {
      my ($self) = @_;
      return 1 if $self->env('SHELL') =~ /(t?csh)/;
      return 0;
  }
  
  # Entry point method: handles all the arguments
  # and dispatches to an appropriate internal
  # method to execute the corresponding command.
  sub run {
      my ($self) = @_;
      $self->run_command( $self->args );
  }
  
  sub args {
      my ($self) = @_;
  
      # keep 'force' and 'yes' coherent across commands
      $self->{force} = $self->{yes} = 1 if ( $self->{force} || $self->{yes} );
  
      return @{ $self->{args} };
  }
  
  sub commands {
      my ($self) = @_;
  
      my $package = ref $self ? ref $self : $self;
  
      my @commands;
      my $symtable = do {
          no strict 'refs';
          \%{ $package . '::' };
      };
  
      foreach my $sym ( keys %$symtable ) {
          if ( $sym =~ /^run_command_/ ) {
              my $glob = $symtable->{$sym};
              if ( ref($glob) eq 'CODE' || defined *$glob{CODE} ) {
  
                  # with perl >= 5.27 stash entry can points to a CV directly
                  $sym =~ s/^run_command_//;
                  $sym =~ s/_/-/g;
                  push @commands, $sym;
              }
          }
      }
  
      return @commands;
  }
  
  sub find_similar_commands {
      my ( $self, $command ) = @_;
  
      $command =~ s/_/-/g;
  
      return @{ find_similar_tokens($command, [ sort $self->commands ]) };
  }
  
  # This method is called in the 'run' loop
  # and executes every specific action depending
  # on the type of command.
  #
  # The first argument to this method is a self reference,
  # while the first "real" argument is the command to execute.
  # Other parameters after the command to execute are
  # considered as arguments for the command itself.
  #
  # In general the command is executed via a method named after the
  # command itself and with the 'run_command' prefix. For instance
  # the command 'exec' is handled by a method
  # `run_command_exec`
  #
  # If no candidates can be found, an execption is thrown
  # and a similar command is shown to the user.
  sub run_command {
      my ( $self, $x, @args ) = @_;
      my $command = $x;
  
      if ( $self->{version} ) {
          $x = 'version';
      }
      elsif ( !$x ) {
          $x    = 'help';
          @args = ( 0, 0 );
      }
      elsif ( $x eq 'help' ) {
          @args = ( 0, 2 ) unless @args;
      }
  
      my $s = $self->can("run_command_$x");
      unless ($s) {
          $x =~ y/-/_/;
          $s = $self->can("run_command_$x");
      }
  
      unless ($s) {
          my @commands = $self->find_similar_commands($x);
  
          if ( @commands > 1 ) {
              @commands = map { '    ' . $_ } @commands;
              die "Unknown command: `$command`. Did you mean one of the following?\n" . join( "\n", @commands ) . "\n";
          }
          elsif ( @commands == 1 ) {
              die "Unknown command: `$command`. Did you mean `$commands[0]`?\n";
          }
          else {
              die "Unknown command: `$command`. Typo?\n";
          }
      }
  
      $self->$s(@args);
  }
  
  sub run_command_version {
      my ($self)  = @_;
      my $package = ref $self;
      my $version = $self->VERSION;
      print "$0  - $package/$version\n";
  }
  
  # Provides help information about a command.
  # The idea is similar to the 'run_command' and 'run_command_$x' chain:
  # this method dispatches to a 'run_command_help_$x' method
  # if found in the class, otherwise it tries to extract the help
  # documentation via the POD of the class itself using the
  # section 'COMMAND: $x' with uppercase $x.
  sub run_command_help {
      my ( $self, $status, $verbose, $return_text ) = @_;
  
      require Pod::Usage;
  
      if ( $status && !defined($verbose) ) {
          if ( $self->can("run_command_help_${status}") ) {
              $self->can("run_command_help_${status}")->($self);
          }
          else {
              my $out = "";
              open my $fh, ">", \$out;
  
              Pod::Usage::pod2usage(
                  -exitval   => "NOEXIT",
                  -verbose   => 99,
                  -sections  => "COMMAND: " . uc($status),
                  -output    => $fh,
                  -noperldoc => 1
              );
              $out =~ s/\A[^\n]+\n//s;
              $out =~ s/^    //gm;
  
              if ( $out =~ /\A\s*\Z/ ) {
                  $out = "Cannot find documentation for '$status'\n\n";
              }
  
              return "\n$out" if ($return_text);
              print "\n$out";
              close $fh;
          }
      }
      else {
          Pod::Usage::pod2usage(
              -noperldoc => 1,
              -verbose   => $verbose || 0,
              -exitval   => ( defined $status ? $status : 1 )
          );
      }
  }
  
  # introspection for compgen
  my %comp_installed = (
      use    => 1,
      switch => 1,
  );
  
  sub run_command_compgen {
      my ( $self, $cur, @args ) = @_;
  
      $cur = 0 unless defined($cur);
  
      # do `tail -f bashcomp.log` for debugging
      if ( $self->env('PERLBREW_DEBUG_COMPLETION') ) {
          open my $log, '>>', 'bashcomp.log';
          print $log "[$$] $cur of [@args]\n";
      }
      my $subcommand           = $args[1];
      my $subcommand_completed = ( $cur >= 2 );
  
      if ( !$subcommand_completed ) {
          $self->_compgen( $subcommand, $self->commands );
      }
      else {    # complete args of a subcommand
          if ( $comp_installed{$subcommand} ) {
              if ( $cur <= 2 ) {
                  my $part;
                  if ( defined( $part = $args[2] ) ) {
                      $part = qr/ \Q$part\E /xms;
                  }
                  $self->_compgen( $part, map { $_->{name} } $self->installed_perls() );
              }
          }
          elsif ( $subcommand eq 'help' ) {
              if ( $cur <= 2 ) {
                  $self->_compgen( $args[2], $self->commands() );
              }
          }
          else {
              # TODO
          }
      }
  }
  
  sub _firstrcfile {
      my ( $self, @files ) = @_;
      foreach my $path (@files) {
          return $path if -f App::Perlbrew::Path->new( $self->env('HOME'), $path );
      }
      return;
  }
  
  sub _compgen {
      my ( $self, $part, @reply ) = @_;
      if ( defined $part ) {
          $part  = qr/\A \Q$part\E /xms if ref($part) ne ref(qr//);
          @reply = grep { /$part/ } @reply;
      }
      foreach my $word (@reply) {
          print $word, "\n";
      }
  }
  
  # Internal utility function.
  # Given a specific perl version, e.g., perl-5.27.4
  # returns a string with a formatted version number such
  # as 05027004. Such string can be used as a number
  # in order to make either a string comparison
  # or a numeric comparison.
  #
  # In the case of cperl the major number is added by 6
  # so that it would match the project claim of being
  # Perl 5+6 = 11. The final result is then
  # multiplied by a negative factor (-1) in order
  # to make cperl being "less" in the ordered list
  # than a normal Perl installation.
  #
  # The returned string is made by four pieces of two digits each:
  # MMmmppbb
  # where:
  # MM is the major Perl version (e.g., 5 -> 05)
  # mm is the minor Perl version (e.g. 27 -> 27)
  # pp is the patch level (e.g., 4 -> 04)
  # bb is the blead flag: it is 00 for a "normal" release, or 01 for a blead one
  sub comparable_perl_version {
      my ( $self, $perl_version )   = @_;
      my ( $is_cperl, $is_blead )   = ( 0, 0 );
      my ( $major, $minor, $patch ) = ( 0, 0, 0 );
      if ( $perl_version =~ /^(?:(c?perl)-?)?(\d)\.(\d+).(\d+).*/ ) {
          $is_cperl = $1 && ( $1 eq 'cperl' );
          $major    = $2 + ( $is_cperl ? 6 : 0 );    # major version
          $minor    = $3;                            # minor version
          $patch    = $4;                            # patch level
  
      }
      elsif ( $perl_version =~ /^(?:(c?perl)-?)?-?(blead)$/ ) {
  
          # in the case of a blead release use a fake high number
          # to assume it is the "latest" release number available
          $is_cperl = $1 && ( $1 eq 'cperl' );
          $is_blead = $2 && ( $2 eq 'blead' );
          ( $major, $minor, $patch ) = ( 5, 99, 99 );
      }
  
      return ( $is_cperl ? -1 : 1 ) * sprintf(
          '%02d%02d%02d%02d',
          $major + ( $is_cperl ? 6 : 0 ),    # major version
          $minor,                            # minor version
          $patch,                            # patch level
          $is_blead
      );                                     # blead
  }
  
  # Internal method.
  # Performs a comparable sort of the perl versions specified as
  # list.
  sub sort_perl_versions {
      my ( $self, @perls ) = @_;
  
      return map { $_->[0] }
          sort   { ( $self->{reverse} ? $a->[1] <=> $b->[1] : $b->[1] <=> $a->[1] ) }
          map    { [$_, $self->comparable_perl_version($_)] } @perls;
  }
  
  sub run_command_available {
      my ($self) = @_;
  
      my @installed  = $self->installed_perls(@_);
      my $is_verbose = $self->{verbose};
  
      my @sections = ( ['perl', 'available_perl_distributions'] );
  
      for (@sections) {
          my ( $header, $method ) = @$_;
  
          print "# $header\n";
  
          my $perls = $self->$method;
  
          # sort the keys of Perl installation (Randal to the rescue!)
          my @sorted_perls = $self->sort_perl_versions( keys %$perls );
  
          for my $available (@sorted_perls) {
              my $url = $perls->{$available};
              my $ctime;
  
              for my $installed (@installed) {
                  my $name = $installed->{name};
                  my $cur  = $installed->{is_current};
                  if ( $available eq $installed->{name} ) {
                      $ctime = $installed->{ctime};
                      last;
                  }
              }
  
              printf "%1s %12s  %s %s\n", $ctime ? 'i' : '', $available,
                  (
                    $is_verbose
                  ? $ctime
                          ? "INSTALLED on $ctime via"
                          : 'available from '
                  : ''
                  ),
                  ( $is_verbose ? "<$url>" : '' );
          }
          print "\n\n";
      }
  
      return;
  }
  
  sub available_perls {
      my ($self) = @_;
      my %dists = ( %{ $self->available_perl_distributions } );
      return $self->sort_perl_versions( keys %dists );
  }
  
  # -> Map[ NameVersion =>  URL ]
  sub available_perl_distributions {
      my ($self) = @_;
      my $perls = {};
      my @perllist;
  
      # we got impatient waiting for cpan.org to get updated to show 5.28...
      # So, we also fetch from metacpan for anything that looks perlish,
      # and we do our own processing to filter out the development
      # releases and minor versions when needed (using
      # filter_perl_available)
      my $json = http_get('https://fastapi.metacpan.org/v1/release/versions/perl')
          or die "\nERROR: Unable to retrieve list of perls from Metacpan.\n\n";
  
      my $decoded = decode_json($json);
      for my $release ( @{ $decoded->{releases} } ) {
          push @perllist, [$release->{name}, $release->{download_url}];
      }
      foreach my $perl ( $self->filter_perl_available( \@perllist ) ) {
          $perls->{ $perl->[0] } = $perl->[1];
      }
  
      return $perls;
  }
  
  # $perllist is an arrayref of arrayrefs.  The inner arrayrefs are of the
  # format: [ <perl_name>, <perl_url> ]
  #   perl_name = something like perl-5.28.0
  #   perl_url  = URL the Perl is available from.
  #
  # If $self->{all} is true, this just returns a list of the contents of
  # the list referenced by $perllist
  #
  # Otherwise, this looks for even middle numbers in the version and no
  # suffix (like -RC1) following the URL, and returns the list of
  # arrayrefs that so match
  #
  # If any "newest" Perl has a
  sub filter_perl_available {
      my ( $self, $perllist ) = @_;
  
      if ( $self->{all} ) { return @$perllist; }
  
      my %max_release;
      foreach my $perl (@$perllist) {
          my $ver = $perl->[0];
          if ( $ver !~ m/^perl-5\.[0-9]*[02468]\.[0-9]+$/ ) { next; }    # most likely TRIAL or RC, or a DEV release
  
          my ( $release_line, $minor ) = $ver =~ m/^perl-5\.([0-9]+)\.([0-9]+)/;
          if ( exists $max_release{$release_line} ) {
              if ( $max_release{$release_line}->[0] > $minor ) { next; }    # We have a newer release
          }
  
          $max_release{$release_line} = [$minor, $perl];
      }
  
      return map { $_->[1] } values %max_release;
  }
  
  sub perl_release {
      my ( $self, $version ) = @_;
      my $mirror = $self->cpan_mirror();
  
      # try CPAN::Perl::Releases
      my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
  
      my $x = ( values %$tarballs )[0];
      if ($x) {
          my $dist_tarball     = ( split( "/", $x ) )[-1];
          my $dist_tarball_url = "$mirror/authors/id/$x";
          return ( $dist_tarball, $dist_tarball_url );
      }
  
      # try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz
      my $index = http_get("https://cpan.metacpan.org/src/5.0/");
      if ($index) {
          for my $prefix ( "perl-", "perl" ) {
              for my $suffix ( ".tar.bz2", ".tar.gz" ) {
                  my $dist_tarball     = "$prefix$version$suffix";
                  my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball";
                  return ( $dist_tarball, $dist_tarball_url )
                      if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms );
              }
          }
      }
  
      my $json = http_get("https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}");
  
      my $result;
      unless ( $json and $result = decode_json($json)->{hits}{hits}[0] ) {
          die "ERROR: Failed to locate perl-${version} tarball.";
      }
  
      my ( $dist_path, $dist_tarball ) =
          $result->{_source}{download_url} =~ m[(/authors/id/.+/(perl-${version}.tar.(gz|bz2|xz)))$];
      die "ERROR: Cannot find the tarball for perl-$version\n"
          if !$dist_path and !$dist_tarball;
      my $dist_tarball_url = "https://cpan.metacpan.org${dist_path}";
      return ( $dist_tarball, $dist_tarball_url );
  }
  
  sub release_detail_perl_local {
      my ( $self, $dist, $rd ) = @_;
      $rd ||= {};
      my $error    = 1;
      my $mirror   = $self->cpan_mirror();
      my $tarballs = CPAN::Perl::Releases::perl_tarballs( $rd->{version} );
      if ( keys %$tarballs ) {
          for ( "tar.bz2", "tar.gz" ) {
              if ( my $x = $tarballs->{$_} ) {
                  $rd->{tarball_name} = ( split( "/", $x ) )[-1];
                  $rd->{tarball_url}  = "$mirror/authors/id/$x";
                  $error              = 0;
                  last;
              }
          }
      }
      return ( $error, $rd );
  }
  
  sub release_detail_perl_remote {
      my ( $self, $dist, $rd ) = @_;
      $rd ||= {};
      my $error  = 1;
      my $mirror = $self->cpan_mirror();
  
      my $version = $rd->{version};
  
      # try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz
      my $index = http_get("https://cpan.metacpan.org/src/5.0/");
      if ($index) {
          for my $prefix ( "perl-", "perl" ) {
              for my $suffix ( ".tar.bz2", ".tar.gz" ) {
                  my $dist_tarball     = "$prefix$version$suffix";
                  my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball";
                  if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms ) {
                      $rd->{tarball_url}  = $dist_tarball_url;
                      $rd->{tarball_name} = $dist_tarball;
                      $error              = 0;
                      return ( $error, $rd );
                  }
              }
          }
      }
  
      my $json = http_get("https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}");
  
      my $result;
      unless ( $json and $result = decode_json($json)->{hits}{hits}[0] ) {
          die "ERROR: Failed to locate perl-${version} tarball.";
      }
  
      my ( $dist_path, $dist_tarball ) =
          $result->{_source}{download_url} =~ m[(/authors/id/.+/(perl-${version}.tar.(gz|bz2|xz)))$];
      die "ERROR: Cannot find the tarball for perl-$version\n"
          if !$dist_path and !$dist_tarball;
      my $dist_tarball_url = "https://cpan.metacpan.org${dist_path}";
  
      $rd->{tarball_name} = $dist_tarball;
      $rd->{tarball_url}  = $dist_tarball_url;
      $error              = 0;
  
      return ( $error, $rd );
  }
  
  sub release_detail {
      my ( $self, $dist ) = @_;
      my ( $dist_type, $dist_version );
  
      ( $dist_type, $dist_version ) = $dist =~ /^ (?: (perl) -? )? ( [\d._]+ (?:-RC\d+)? |git|stable|blead)$/x;
      $dist_type = "perl" if $dist_version && !$dist_type;
  
      my $rd = {
          type         => $dist_type,
          version      => $dist_version,
          tarball_url  => undef,
          tarball_name => undef,
      };
  
      # dynamic methods: release_detail_perl_local, release_detail_perl_remote
      my $m_local  = "release_detail_${dist_type}_local";
      my $m_remote = "release_detail_${dist_type}_remote";
  
      unless ($self->can($m_local) && $self->can($m_remote)) {
          die "ERROR: Unknown dist type: $dist_type\n";
      }
  
      my ($error) = $self->$m_local( $dist, $rd );
      ($error) = $self->$m_remote( $dist, $rd ) if $error;
  
      if ($error) {
          die "ERROR: Fail to get the tarball URL for dist: $dist\n";
      }
  
      return $rd;
  }
  
  sub run_command_init {
      my $self = shift;
      my @args = @_;
  
      if ( @args && $args[0] eq '-' ) {
          if ( $self->current_shell_is_bashish ) {
              $self->run_command_init_in_bash;
          }
          exit 0;
      }
  
      $_->mkpath for ( grep { !-d $_ } map { $self->root->$_ } qw(perls dists build etc bin) );
  
      my ( $f, $fh ) = @_;
  
      my $etc_dir = $self->root->etc;
  
      for (
          ["bashrc",                   "BASHRC_CONTENT"],
          ["cshrc",                    "CSHRC_CONTENT"],
          ["csh_reinit",               "CSH_REINIT_CONTENT"],
          ["csh_wrapper",              "CSH_WRAPPER_CONTENT"],
          ["csh_set_path",             "CSH_SET_PATH_CONTENT"],
          ["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"],
          ["perlbrew.fish",            "PERLBREW_FISH_CONTENT"],
          )
      {
          my ( $file_name, $method ) = @$_;
          my $path = $etc_dir->child($file_name);
          if ( !-f $path ) {
              open( $fh, ">", $path )
                  or die "Fail to create $path. Please check the permission of $etc_dir and try `perlbrew init` again.";
              print $fh $self->$method;
              close $fh;
          }
          else {
              if ( -w $path && open( $fh, ">", $path ) ) {
                  print $fh $self->$method;
                  close $fh;
              }
              else {
                  print "NOTICE: $path already exists and not updated.\n" unless $self->{quiet};
              }
          }
      }
  
      my $root_dir = $self->root->stringify_with_tilde;
  
      # Skip this if we are running in a shell that already 'source's perlbrew.
      # This is true during a self-install/self-init.
      # Ref. https://github.com/gugod/App-perlbrew/issues/525
      if ( $ENV{PERLBREW_SHELLRC_VERSION} ) {
          print("\nperlbrew root ($root_dir) is initialized.\n");
      }
      else {
          my $shell = $self->current_shell;
          my ( $code, $yourshrc );
          if ( $shell =~ m/(t?csh)/ ) {
              $code     = "source $root_dir/etc/cshrc";
              $yourshrc = $1 . "rc";
          }
          elsif ( $shell =~ m/zsh\d?$/ ) {
              $code     = "source $root_dir/etc/bashrc";
              $yourshrc = $self->_firstrcfile(
                  qw(
                      .zshenv
                      .bash_profile
                      .bash_login
                      .profile
                  )
              ) || ".zshenv";
          }
          elsif ( $shell =~ m/fish/ ) {
              $code     = ". $root_dir/etc/perlbrew.fish";
              $yourshrc = '.config/fish/config.fish';
          }
          else {
              $code     = "source $root_dir/etc/bashrc";
              $yourshrc = $self->_firstrcfile(
                  qw(
                      .bash_profile
                      .bash_login
                      .profile
                  )
              ) || ".bash_profile";
          }
  
          if ( $self->home ne App::Perlbrew::Path->new( $self->env('HOME'), ".perlbrew" ) ) {
              my $pb_home_dir = $self->home->stringify_with_tilde;
              if ( $shell =~ m/fish/ ) {
                  $code = "set -x PERLBREW_HOME $pb_home_dir\n    $code";
              }
              else {
                  $code = "export PERLBREW_HOME=$pb_home_dir\n    $code";
              }
          }
  
          print <<INSTRUCTION;
  
  perlbrew root ($root_dir) is initialized.
  
  Append the following piece of code to the end of your ~/${yourshrc} and start a
  new shell, perlbrew should be up and fully functional from there:
  
      $code
  
  Simply run `perlbrew` for usage details.
  
  Happy brewing!
  
  INSTRUCTION
      }
  
  }
  
  sub run_command_init_in_bash {
      print BASHRC_CONTENT();
  }
  
  sub run_command_self_install {
      my $self = shift;
  
      my $executable = $0;
      my $target     = $self->root->bin("perlbrew");
  
      if ( files_are_the_same( $executable, $target ) ) {
          print "You are already running the installed perlbrew:\n\n    $executable\n";
          exit;
      }
  
      $self->root->bin->mkpath;
  
      open my $fh, "<", $executable;
  
      my $head;
      read( $fh, $head, 3, 0 );
  
      if ( $head eq "#!/" ) {
          seek( $fh, 0, 0 );
          my @lines = <$fh>;
          close $fh;
  
          $lines[0] = $self->system_perl_shebang . "\n";
  
          open $fh, ">", $target;
          print $fh $_ for @lines;
          close $fh;
      }
      else {
          close($fh);
  
          copy( $executable, $target );
      }
  
      chmod( 0755, $target );
  
      my $path = $target->stringify_with_tilde;
  
      print "perlbrew is installed: $path\n" unless $self->{quiet};
  
      $self->run_command_init();
      return;
  }
  
  sub do_install_git {
      my ( $self, $dist ) = @_;
      my $dist_name;
      my $dist_git_describe;
      my $dist_version;
  
      opendir my $cwd_orig, ".";
  
      chdir $dist;
  
      if ( `git describe` =~ /v((5\.\d+\.\d+(?:-RC\d)?)(-\d+-\w+)?)$/ ) {
          $dist_name         = 'perl';
          $dist_git_describe = "v$1";
          $dist_version      = $2;
      }
  
      chdir $cwd_orig;
  
      require File::Spec;
      my $dist_extracted_dir = File::Spec->rel2abs($dist);
      $self->do_install_this( App::Perlbrew::Path->new($dist_extracted_dir), $dist_version, "$dist_name-$dist_version" );
      return;
  }
  
  sub do_install_url {
      my ( $self, $dist ) = @_;
      my $dist_name = 'perl';
  
      # need the period to account for the file extension
      my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./;
      my ($dist_tarball) = $dist =~ m{/([^/]*)$};
  
      if ( !$dist_version && $dist =~ /blead\.tar.gz$/ ) {
          $dist_version = "blead";
      }
  
      my $dist_tarball_path = $self->root->dists($dist_tarball);
      my $dist_tarball_url  = $dist;
      $dist = "$dist_name-$dist_version";    # we install it as this name later
  
      if ( $dist_tarball_url =~ m/^file/ ) {
          print "Installing $dist from local archive $dist_tarball_url\n";
          $dist_tarball_url =~ s/^file:\/+/\//;
          $dist_tarball_path = $dist_tarball_url;
      }
      else {
          print "Fetching $dist as $dist_tarball_path\n";
          my $error = http_download( $dist_tarball_url, $dist_tarball_path );
          die "ERROR: Failed to download $dist_tarball_url\n$error\n" if $error;
      }
  
      my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
      $self->do_install_this( $dist_extracted_path, $dist_version, $dist );
      return;
  }
  
  sub do_extract_tarball {
      my ( $self, $dist_tarball ) = @_;
  
      # Assuming the dir extracted from the tarball is named after the tarball.
      my $dist_tarball_basename = $dist_tarball->basename(qr/\.tar\.(?:gz|bz2|xz)$/);
  
      my $workdir;
      if ( $self->{as} ) {
  
          # TODO: Should we instead use the installation_name (see run_command_install()):
          #    $destdir = $self->{as} . $self->{variation} . $self->{append};
          $workdir = $self->builddir->child( $self->{as} );
      }
      else {
          # Note that this is incorrect for blead.
          $workdir = $self->builddir->child($dist_tarball_basename);
      }
      $workdir->rmpath;
      $workdir->mkpath;
      my $extracted_dir;
  
      # Was broken on Solaris, where GNU tar is probably
      # installed as 'gtar' - RT #61042
      my $tarx = ( $^O =~ /solaris|aix/ ? 'gtar ' : 'tar ' )
          . (
            $dist_tarball =~ m/xz$/  ? 'xJf'
          : $dist_tarball =~ m/bz2$/ ? 'xjf'
          :                            'xzf'
          );
  
      my $extract_command = "cd $workdir; $tarx $dist_tarball";
      die "Failed to extract $dist_tarball" if system($extract_command);
  
      my @things = $workdir->children;
      if ( @things == 1 ) {
          $extracted_dir = App::Perlbrew::Path->new( $things[0] );
      }
  
      unless ( defined($extracted_dir) && -d $extracted_dir ) {
          die "Failed to find the extracted directory under $workdir";
      }
  
      return $extracted_dir;
  }
  
  sub do_install_blead {
      my ($self) = @_;
  
      # We always blindly overwrite anything that's already there,
      # because blead is a moving target.
      my $dist_tarball_path = $self->root->dists("blead.tar.gz");
      unlink($dist_tarball_path) if -f $dist_tarball_path;
  
      $self->do_install_url("https://github.com/Perl/perl5/archive/blead.tar.gz");
  }
  
  sub resolve_stable_version {
      my ($self) = @_;
  
      my ( $latest_ver, $latest_minor );
      for my $cand ( $self->available_perls ) {
          my ( $ver, $minor ) = $cand =~ m/^perl-(5\.(6|8|[0-9]+[02468])\.[0-9]+)$/
              or next;
          ( $latest_ver, $latest_minor ) = ( $ver, $minor )
              if !defined $latest_minor
              || $latest_minor < $minor;
      }
  
      die "Can't determine latest stable Perl release\n"
          if !defined $latest_ver;
  
      return $latest_ver;
  }
  
  sub do_install_release {
      my ( $self, $dist, $dist_version ) = @_;
  
      my $rd        = $self->release_detail($dist);
      my $dist_type = $rd->{type};
  
      die "\"$dist\" does not look like a perl distribution name. " unless $dist_type && $dist_version =~ /^\d\./;
  
      my $dist_tarball      = $rd->{tarball_name};
      my $dist_tarball_url  = $rd->{tarball_url};
      my $dist_tarball_path = $self->root->dists($dist_tarball);
  
      if ( -f $dist_tarball_path ) {
          print "Using the previously fetched ${dist_tarball}\n"
              if $self->{verbose};
      }
      else {
          print "Fetching perl $dist_version as $dist_tarball_path\n" unless $self->{quiet};
          $self->run_command_download($dist);
      }
  
      my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
      $self->do_install_this( $dist_extracted_path, $dist_version, $dist );
      return;
  }
  
  sub run_command_install {
      my ( $self, $dist, $opts ) = @_;
  
      unless ( $self->root->exists ) {
          die( "ERROR: perlbrew root " . $self->root . " does not exist. Run `perlbrew init` to prepare it first.\n" );
      }
  
      unless ($dist) {
          $self->run_command_help("install");
          exit(-1);
      }
  
      $self->{dist_name} = $dist;    # for help msg generation, set to non
                                     # normalized name
  
      my ( $dist_type, $dist_version );
      if ( ( $dist_type, $dist_version ) = $dist =~ /^(?:(c?perl)-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/ ) {
          $dist_version = $self->resolve_stable_version if $dist_version eq 'stable';
          $dist_type ||= "perl";
          $dist = "${dist_type}-${dist_version}";    # normalize dist name
  
          my $installation_name = ( $self->{as} || $dist ) . $self->{variation} . $self->{append};
          if ( not $self->{force} and $self->is_installed($installation_name) ) {
              die "\nABORT: $installation_name is already installed.\n\n";
          }
  
          if ( $dist_type eq 'perl' && $dist_version eq 'blead' ) {
              $self->do_install_blead();
          }
          else {
              $self->do_install_release( $dist, $dist_version );
          }
  
      }
  
      # else it is some kind of special install:
      elsif ( -d "$dist/.git" ) {
          $self->do_install_git($dist);
      }
      elsif ( -f $dist ) {
          $self->do_install_archive( App::Perlbrew::Path->new($dist) );
      }
      elsif ( $dist =~ m/^(?:https?|ftp|file)/ ) {    # more protocols needed?
          $self->do_install_url($dist);
      }
      else {
          die "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` "
              . "for the instruction on using the install command.\n\n";
      }
  
      if ( $self->{switch} ) {
          if ( defined( my $installation_name = $self->{installation_name} ) ) {
              $self->switch_to($installation_name);
          }
          else {
              warn "can't switch, unable to infer final destination name.\n\n";
          }
      }
      return;
  }
  
  sub check_and_calculate_variations {
      my $self = shift;
      my @both = @{ $self->{both} };
  
      if ( $self->{'all-variations'} ) {
          @both = keys %flavor;
      }
      elsif ( $self->{'common-variations'} ) {
          push @both, grep $flavor{$_}{common}, keys %flavor;
      }
  
      # check the validity of the varitions given via 'both'
      for my $both (@both) {
          $flavor{$both} or die "$both is not a supported flavor.\n\n";
          $self->{$both} and die "options --both $both and --$both can not be used together";
          if ( my $implied_by = $flavor{$both}{implied_by} ) {
              $self->{$implied_by} and die "options --both $both and --$implied_by can not be used together";
          }
      }
  
      # flavors selected always
      my $start = '';
      $start .= "-$_" for grep $self->{$_}, keys %flavor;
  
      # make variations
      my @var = $start;
      for my $both (@both) {
          my $append = join( '-', $both, grep defined, $flavor{$both}{implies} );
          push @var, map "$_-$append", @var;
      }
  
      # normalize the variation names
      @var = map {
          join '-', '', sort { $flavor{$a}{ix} <=> $flavor{$b}{ix} } grep length, split /-+/, $_
      } @var;
      s/(\b\w+\b)(?:-\1)+/$1/g for @var;    # remove duplicate flavors
  
      # After inspecting perl Configure script this seems to be the most
      # reliable heuristic to determine if perl would have 64bit IVs by
      # default or not:
      if ( $Config::Config{longsize} >= 8 ) {
  
          # We are in a 64bit platform. 64int and 64all are always set but
          # we don't want them to appear on the final perl name
          s/-64\w+//g for @var;
      }
  
      # remove duplicated variations
      my %var = map { $_ => 1 } @var;
      sort keys %var;
  }
  
  sub run_command_install_multiple {
      my ( $self, @dists ) = @_;
  
      unless (@dists) {
          $self->run_command_help("install-multiple");
          exit(-1);
      }
  
      die "--switch can not be used with command install-multiple.\n\n"
          if $self->{switch};
      die "--as can not be used when more than one distribution is given.\n\n"
          if $self->{as} and @dists > 1;
  
      my @variations = $self->check_and_calculate_variations;
      print join( "\n",
          "Compiling the following distributions:",
          map( "    $_$self->{append}", @dists ),
          "  with the following variations:",
          map( ( /-(.*)/ ? "    $1" : "    default" ), @variations ),
          "", "" );
  
      my @ok;
      for my $dist (@dists) {
          for my $variation (@variations) {
              local $@;
              eval {
                  $self->{$_}                = '' for keys %flavor;
                  $self->{$_}                = 1  for split /-/, $variation;
                  $self->{variation}         = $variation;
                  $self->{installation_name} = undef;
  
                  $self->run_command_install($dist);
                  push @ok, $self->{installation_name};
              };
              if ($@) {
                  $@ =~ s/\n+$/\n/;
                  print "Installation of $dist$variation failed: $@";
              }
          }
      }
  
      print join( "\n", "", "The following perls have been installed:", map ( "    $_", grep defined, @ok ), "", "" );
      return;
  }
  
  sub run_command_download {
      my ( $self, $dist ) = @_;
  
      $dist = $self->resolve_stable_version
          if $dist && $dist eq 'stable';
  
      my $rd = $self->release_detail($dist);
  
      my $dist_tarball      = $rd->{tarball_name};
      my $dist_tarball_url  = $rd->{tarball_url};
      my $dist_tarball_path = $self->root->dists($dist_tarball);
  
      if ( -f $dist_tarball_path && !$self->{force} ) {
          print "$dist_tarball already exists\n";
      }
      else {
          print "Download $dist_tarball_url to $dist_tarball_path\n" unless $self->{quiet};
          my $error = http_download( $dist_tarball_url, $dist_tarball_path );
          if ($error) {
              die "ERROR: Failed to download $dist_tarball_url\n$error\n";
          }
      }
  }
  
  sub purify {
      my ( $self, $envname ) = @_;
      my @paths = grep { index( $_, $self->home ) < 0 && index( $_, $self->root ) < 0 } split /:/, $self->env($envname);
      return wantarray ? @paths : join( ":", @paths );
  }
  
  sub system_perl_executable {
      my ($self) = @_;
  
      my $system_perl_executable = do {
          local $ENV{PATH} = $self->pristine_path;
          `perl -MConfig -e 'print \$Config{perlpath}'`;
      };
  
      return $system_perl_executable;
  }
  
  sub system_perl_shebang {
      my ($self) = @_;
      return $Config{sharpbang} . $self->system_perl_executable;
  }
  
  sub pristine_path {
      my ($self) = @_;
      return $self->purify("PATH");
  }
  
  sub pristine_manpath {
      my ($self) = @_;
      return $self->purify("MANPATH");
  }
  
  sub run_command_display_system_perl_executable {
      print $_[0]->system_perl_executable . "\n";
  }
  
  sub run_command_display_system_perl_shebang {
      print $_[0]->system_perl_shebang . "\n";
  }
  
  sub run_command_display_pristine_path {
      print $_[0]->pristine_path . "\n";
  }
  
  sub run_command_display_pristine_manpath {
      print $_[0]->pristine_manpath . "\n";
  }
  
  sub do_install_archive {
      require File::Basename;
  
      my $self              = shift;
      my $dist_tarball_path = shift;
      my $dist_version;
      my $installation_name;
  
      if ( $dist_tarball_path->basename =~ m{(c?perl)-?(5.+)\.tar\.(gz|bz2|xz)\Z} ) {
          my $perl_variant = $1;
          $dist_version      = $2;
          $installation_name = "${perl_variant}-${dist_version}";
      }
  
      unless ( $dist_version && $installation_name ) {
          die
  "Unable to determine perl version from archive filename.\n\nThe archive name should look like perl-5.x.y.tar.gz or perl-5.x.y.tar.bz2 or perl-5.x.y.tar.xz\n";
      }
  
      my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
  
      $self->do_install_this( $dist_extracted_path, $dist_version, $installation_name );
  }
  
  sub do_install_this {
      my ( $self, $dist_extracted_dir, $dist_version, $installation_name ) = @_;
  
      my $variation                          = $self->{variation};
      my $append                             = $self->{append};
      my $looks_like_we_are_installing_cperl = $dist_extracted_dir =~ /\/ cperl- /x;
  
      $self->{dist_extracted_dir} = $dist_extracted_dir;
      $self->{log_file}           = $self->root->child("build.${installation_name}${variation}${append}.log");
  
      my @d_options     = @{ $self->{D} };
      my @u_options     = @{ $self->{U} };
      my @a_options     = @{ $self->{A} };
      my $sitecustomize = $self->{sitecustomize};
      my $destdir       = $self->{destdir};
      $installation_name = $self->{as} if $self->{as};
      $installation_name .= "$variation$append";
  
      $self->{installation_name} = $installation_name;
  
      if ($sitecustomize) {
          die "Could not read sitecustomize file '$sitecustomize'\n"
              unless -r $sitecustomize;
          push @d_options, "usesitecustomize";
      }
  
      if ( $self->{noman} ) {
          push @d_options, qw/man1dir=none man3dir=none/;
      }
  
      for my $flavor ( keys %flavor ) {
          $self->{$flavor} and push @d_options, $flavor{$flavor}{d_option};
      }
  
      my $perlpath = $self->root->perls($installation_name);
  
      unshift @d_options, qq(prefix=$perlpath);
      push @d_options, "usedevel" if $dist_version =~ /5\.\d[13579]|git|blead/;
  
      push @d_options, "usecperl" if $looks_like_we_are_installing_cperl;
  
      my $version = $self->comparable_perl_version($dist_version);
      if ( defined $version and $version < $self->comparable_perl_version('5.6.0') ) {
  
          # ancient perls do not support -A for Configure
          @a_options = ();
      }
      else {
          unless ( grep { /eval:scriptdir=/ } @a_options ) {
              push @a_options, "'eval:scriptdir=${perlpath}/bin'";
          }
      }
  
      print "Installing $dist_extracted_dir into "
          . $self->root->perls($installation_name)->stringify_with_tilde . "\n\n";
      print <<INSTALL if !$self->{verbose};
  This could take a while. You can run the following command on another shell to track the status:
  
    tail -f ${\ $self->{log_file}->stringify_with_tilde }
  
  INSTALL
  
      my @preconfigure_commands = ( "cd $dist_extracted_dir", "rm -f config.sh Policy.sh", );
  
      unless ( $self->{"no-patchperl"} || $looks_like_we_are_installing_cperl ) {
          my $patchperl = $self->root->bin("patchperl");
  
          unless ( -x $patchperl && -f _ ) {
              $patchperl = "patchperl";
          }
  
          push @preconfigure_commands, 'chmod -R +w .', $patchperl;
      }
  
      my $configure_flags = $self->env("PERLBREW_CONFIGURE_FLAGS") || '-de';
  
      my @configure_commands = (
          "sh Configure $configure_flags "
              . join( ' ',
              ( map { qq{'-D$_'} } @d_options ),
              ( map { qq{'-U$_'} } @u_options ),
              ( map { qq{'-A$_'} } @a_options ),
              ),
          ( defined $version and $version < $self->comparable_perl_version('5.8.9') )
          ? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile")
          : ()
      );
  
      my $make           = $ENV{MAKE} || ( $^O eq "solaris" ? 'gmake' : 'make' );
      my @build_commands = ( $make . ' ' . ( $self->{j} ? "-j$self->{j}" : "" ) );
  
      # Test via "make test_harness" if available so we'll get
      # automatic parallel testing via $HARNESS_OPTIONS. The
      # "test_harness" target was added in 5.7.3, which was the last
      # development release before 5.8.0.
      my $use_harness = ( $dist_version =~ /^5\.(\d+)\.(\d+)/
                          && ( $1 >= 8 || $1 == 7 && $2 == 3 ) )
          || $dist_version eq "blead";
      my $test_target = $use_harness ? "test_harness" : "test";
  
      local $ENV{TEST_JOBS} = $self->{j}
          if $test_target eq "test_harness" && ( $self->{j} || 1 ) > 1;
  
      my @install_commands = ( "${make} install" . ( $destdir ? " DESTDIR=$destdir" : q|| ) );
      unshift @install_commands, "${make} $test_target" unless $self->{notest};
  
    # Whats happening here? we optionally join with && based on $self->{force}, but then subsequently join with && anyway?
      @install_commands = join " && ", @install_commands unless ( $self->{force} );
  
      my $cmd = join " && ", ( @preconfigure_commands, @configure_commands, @build_commands, @install_commands );
  
      $self->{log_file}->unlink;
  
      if ( $self->{verbose} ) {
          $cmd = "($cmd) 2>&1 | tee $self->{log_file}";
          print "$cmd\n" if $self->{verbose};
      }
      else {
          $cmd = "($cmd) >> '$self->{log_file}' 2>&1 ";
      }
  
      delete $ENV{$_} for qw(PERL5LIB PERL5OPT AWKPATH NO_COLOR);
  
      if ( $self->do_system($cmd) ) {
          my $newperl = $self->root->perls($installation_name)->perl;
          unless ( -e $newperl ) {
              $self->run_command_symlink_executables($installation_name);
          }
  
          eval { $self->append_log('##### Brew Finished #####') };
  
          if ($sitecustomize) {
              my $capture = $self->do_capture("$newperl -V:sitelib");
              my ($sitelib) = $capture =~ m/sitelib='([^']*)';/;
              $sitelib = $destdir . $sitelib if $destdir;
              $sitelib = App::Perlbrew::Path->new($sitelib);
              $sitelib->mkpath;
              my $target = $sitelib->child("sitecustomize.pl");
              open my $dst, ">", $target
                  or die "Could not open '$target' for writing: $!\n";
              open my $src, "<", $sitecustomize
                  or die "Could not open '$sitecustomize' for reading: $!\n";
              print {$dst} do { local $/; <$src> };
          }
  
          my $version_file = $self->root->perls($installation_name)->version_file;
  
          if ( -e $version_file ) {
              $version_file->unlink()
                  or die "Could not unlink $version_file file: $!\n";
          }
  
          print "$installation_name is successfully installed.\n";
      }
      else {
          eval { $self->append_log('##### Brew Failed #####') };
          die $self->INSTALLATION_FAILURE_MESSAGE;
      }
      return;
  }
  
  sub do_install_program_from_url {
      my ( $self, $url, $program_name, $body_filter ) = @_;
  
      my $out = $self->root->bin($program_name);
  
      if ( -f $out && !$self->{force} && !$self->{yes} ) {
          require ExtUtils::MakeMaker;
  
          my $ans = ExtUtils::MakeMaker::prompt( "\n$out already exists, are you sure to override ? [y/N]", "N" );
  
          if ( $ans !~ /^Y/i ) {
              print "\n$program_name installation skipped.\n\n" unless $self->{quiet};
              return;
          }
      }
  
      my $body = http_get($url)
          or die "\nERROR: Failed to retrieve $program_name executable.\n\n";
  
      unless ( $body =~ m{\A#!/}s ) {
          my $x = App::Perlbrew::Path->new( $self->env('TMPDIR') || "/tmp", "${program_name}.downloaded.$$" );
          my $message =
  "\nERROR: The downloaded $program_name program seem to be invalid. Please check if the following URL can be reached correctly\n\n\t$url\n\n...and try again latter.";
  
          unless ( -f $x ) {
              open my $OUT, ">", $x;
              print $OUT $body;
              close($OUT);
              $message .= "\n\nThe previously downloaded file is saved at $x for manual inspection.\n\n";
          }
  
          die $message;
      }
  
      if ( $body_filter && ref($body_filter) eq "CODE" ) {
          $body = $body_filter->($body);
      }
  
      $self->root->bin->mkpath;
      open my $OUT, '>', $out or die "cannot open file($out): $!";
      print $OUT $body;
      close $OUT;
      chmod 0755, $out;
      print "\n$program_name is installed to\n\n    $out\n\n" unless $self->{quiet};
  }
  
  sub do_exit_with_error_code {
      my ( $self, $code ) = @_;
      exit($code);
  }
  
  sub do_system_with_exit_code {
      my ( $self, @cmd ) = @_;
      return system(@cmd);
  }
  
  sub do_system {
      my ( $self, @cmd ) = @_;
      return !$self->do_system_with_exit_code(@cmd);
  }
  
  sub do_capture {
      my ( $self, @cmd ) = @_;
      return Capture::Tiny::capture(
          sub {
              $self->do_system(@cmd);
          }
      );
  }
  
  sub format_perl_version {
      my $self    = shift;
      my $version = shift;
      return sprintf "%d.%d.%d", substr( $version, 0, 1 ), substr( $version, 2, 3 ), substr( $version, 5 ) || 0;
  }
  
  sub installed_perls {
      my $self = shift;
  
      my @result;
      my $root = $self->root;
  
      for my $installation ( $root->perls->list ) {
          my $name       = $installation->name;
          my $executable = $installation->perl;
          next unless -f $executable;
  
          my $version_file = $installation->version_file;
          my $ctime        = localtime( ( stat $executable )[10] );    # localtime in scalar context!
  
          my $orig_version;
          if ( -e $version_file ) {
              open my $fh, '<', $version_file;
              local $/;
              $orig_version = <$fh>;
              chomp $orig_version;
          }
          else {
              $orig_version = `$executable -e 'print \$]'`;
              if ( defined $orig_version and length $orig_version ) {
                  if ( open my $fh, '>', $version_file ) {
                      print {$fh} $orig_version;
                  }
              }
          }
  
          push @result,
              {
              name               => $name,
              orig_version       => $orig_version,
              version            => $self->format_perl_version($orig_version),
              is_current         => ( $self->current_perl eq $name ) && !( $self->current_lib ),
              libs               => [$self->local_libs($name)],
              executable         => $executable,
              dir                => $installation,
              comparable_version => $self->comparable_perl_version($orig_version),
              ctime              => $ctime,
              };
      }
  
      return sort {
          (
              $self->{reverse}
              ? ( $a->{comparable_version} <=> $b->{comparable_version} or $b->{name} cmp $a->{name} )
              : ( $b->{comparable_version} <=> $a->{comparable_version} or $a->{name} cmp $b->{name} )
          )
      } @result;
  }
  
  sub compose_locallib {
      my ( $self, $perl_name, $lib_name ) = @_;
      return join '@', $perl_name, $lib_name;
  }
  
  sub decompose_locallib {
      my ( $self, $name ) = @_;
      return split '@', $name;
  }
  
  sub enforce_localib {
      my ( $self, $name ) = @_;
      $name =~ s/^/@/ unless $name =~ m/@/;
      return $name;
  }
  
  sub local_libs {
      my ( $self, $perl_name ) = @_;
  
      my $current = $self->current_env;
      my @libs    = map {
          my $name = $_->basename;
          my ( $p, $l ) = $self->decompose_locallib($name);
          +{
              name       => $name,
              is_current => $name eq $current,
              perl_name  => $p,
              lib_name   => $l,
              dir        => $_,
          }
      } $self->home->child("libs")->children;
      if ($perl_name) {
          @libs = grep { $perl_name eq $_->{perl_name} } @libs;
      }
      return @libs;
  }
  
  sub is_installed {
      my ( $self, $name ) = @_;
  
      return grep { $name eq $_->{name} } $self->installed_perls;
  }
  
  sub assert_known_installation {
      my ( $self, $name ) = @_;
      return 1 if $self->is_installed($name);
      die "ERROR: The installation \"$name\" is unknown\n\n";
  }
  
  # Return a hash of PERLBREW_* variables
  sub perlbrew_env {
      my ( $self, $name ) = @_;
      my ( $perl_name, $lib_name );
  
      if ($name) {
          ( $perl_name, $lib_name ) = $self->resolve_installation_name($name);
  
          unless ($perl_name) {
              die "\nERROR: The installation \"$name\" is unknown.\n\n";
          }
  
          unless ( !$lib_name || grep { $_->{lib_name} eq $lib_name } $self->local_libs($perl_name) ) {
              die "\nERROR: The lib name \"$lib_name\" is unknown.\n\n";
          }
      }
  
      my %env = (
          PERLBREW_VERSION => $VERSION,
          PERLBREW_PATH    => $self->root->bin,
          PERLBREW_MANPATH => "",
          PERLBREW_ROOT    => $self->root
      );
  
      require local::lib;
      my $pb_home                   = $self->home;
      my $current_local_lib_root    = $self->env("PERL_LOCAL_LIB_ROOT") || "";
      my $current_local_lib_context = local::lib->new;
      my @perlbrew_local_lib_root   = uniq( grep { /\Q${pb_home}\E/ } split( /:/, $current_local_lib_root ) );
      if ( $current_local_lib_root =~ /^\Q${pb_home}\E/ ) {
          $current_local_lib_context = $current_local_lib_context->activate($_) for @perlbrew_local_lib_root;
      }
  
      if ($perl_name) {
          my $installation = $self->root->perls($perl_name);
          if ( -d $installation->child("bin") ) {
              $env{PERLBREW_PERL} = $perl_name;
              $env{PERLBREW_PATH} .= ":" . $installation->child("bin");
              $env{PERLBREW_MANPATH} = $installation->child("man");
          }
  
          if ($lib_name) {
              $current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root;
  
              my $base = $self->home->child( "libs", "${perl_name}\@${lib_name}" );
  
              if ( -d $base ) {
                  $current_local_lib_context = $current_local_lib_context->activate($base);
  
                  if ( $self->env('PERLBREW_LIB_PREFIX') ) {
                      unshift
                          @{ $current_local_lib_context->libs },
                          $self->env('PERLBREW_LIB_PREFIX');
                  }
  
                  $env{PERLBREW_PATH}    = $base->child("bin") . ":" . $env{PERLBREW_PATH};
                  $env{PERLBREW_MANPATH} = $base->child("man") . ":" . $env{PERLBREW_MANPATH};
                  $env{PERLBREW_LIB}     = $lib_name;
              }
          }
          else {
              $current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root;
              $env{PERLBREW_LIB} = undef;
          }
  
          my %ll_env = $current_local_lib_context->build_environment_vars;
          delete $ll_env{PATH};
          for my $key ( keys %ll_env ) {
              $env{$key} = $ll_env{$key};
          }
      }
      else {
          $current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root;
  
          my %ll_env = $current_local_lib_context->build_environment_vars;
          delete $ll_env{PATH};
          for my $key ( keys %ll_env ) {
              $env{$key} = $ll_env{$key};
          }
          $env{PERLBREW_LIB}  = undef;
          $env{PERLBREW_PERL} = undef;
      }
  
      return %env;
  }
  
  sub run_command_list {
      my $self       = shift;
      my $is_verbose = $self->{verbose};
  
      if ( $self->{'no-decoration'} ) {
          for my $i ( $self->installed_perls ) {
              print $i->{name} . "\n";
              for my $lib ( @{ $i->{libs} } ) {
                  print $lib->{name} . "\n";
              }
          }
      }
      else {
          for my $i ( $self->installed_perls ) {
              printf "%-2s%-20s %-20s %s\n", $i->{is_current} ? '*' : '', $i->{name},
                  (
                    $is_verbose
                  ? ( index( $i->{name}, $i->{version} ) < 0 )
                          ? "($i->{version})"
                          : ''
                  : ''
                  ),
                  ( $is_verbose ? "(installed on $i->{ctime})" : '' );
  
              for my $lib ( @{ $i->{libs} } ) {
                  print $lib->{is_current} ? "* " : "  ", $lib->{name}, "\n";
              }
          }
      }
  
      return 0;
  }
  
  sub launch_sub_shell {
      my ( $self, $name ) = @_;
      my $shell = $self->env('SHELL');
  
      my $shell_opt = "";
  
      if ( $shell =~ /\/zsh\d?$/ ) {
          $shell_opt = "-d -f";
  
          if ( $^O eq 'darwin' ) {
              my $root_dir = $self->root;
              print <<"WARNINGONMAC";
  --------------------------------------------------------------------------------
  WARNING: zsh perlbrew sub-shell is not working on Mac OSX Lion.
  
  It is known that on MacOS Lion, zsh always resets the value of PATH on launching
  a sub-shell. Effectively nullify the changes required by perlbrew sub-shell. You
  may `echo \$PATH` to examine it and if you see perlbrew related paths are in the
  end, instead of in the beginning, you are unfortunate.
  
  You are advised to include the following line to your ~/.zshenv as a better
  way to work with perlbrew:
  
      source $root_dir/etc/bashrc
  
  --------------------------------------------------------------------------------
  WARNINGONMAC
  
          }
      }
  
      my %env = ( $self->perlbrew_env($name), PERLBREW_SKIP_INIT => 1 );
  
      unless ( $ENV{PERLBREW_VERSION} ) {
          my $root = $self->root;
  
          # The user does not source bashrc/csh in their shell initialization.
          $env{PATH}    = $env{PERLBREW_PATH} . ":" . join ":", grep { !/$root\/bin/ } split ":", $ENV{PATH};
          $env{MANPATH} = $env{PERLBREW_MANPATH} . ":" . join ":",
              grep { !/$root\/man/ } ( defined( $ENV{MANPATH} ) ? split( ":", $ENV{MANPATH} ) : () );
      }
  
      my $command = "env ";
      while ( my ( $k, $v ) = each(%env) ) {
          no warnings "uninitialized";
          $command .= "$k=\"$v\" ";
      }
      $command .= " $shell $shell_opt";
  
      my $pretty_name = defined($name) ? $name : "the default perl";
      print "\nA sub-shell is launched with $pretty_name as the activated perl. Run 'exit' to finish it.\n\n";
      exec($command);
  }
  
  sub run_command_use {
      my $self = shift;
      my $perl = shift;
  
      if ( !$perl ) {
          my $current = $self->current_env;
          if ($current) {
              print "Currently using $current\n";
          }
          else {
              print "No version in use; defaulting to system\n";
          }
          return;
      }
  
      $self->launch_sub_shell($perl);
  
  }
  
  sub run_command_switch {
      my ( $self, $dist, $alias ) = @_;
  
      unless ($dist) {
          my $current = $self->current_env;
          printf "Currently switched %s\n", ( $current ? "to $current" : 'off' );
          return;
      }
  
      $self->switch_to( $dist, $alias );
  }
  
  sub switch_to {
      my ( $self, $dist, $alias ) = @_;
  
      die "Cannot use for alias something that starts with 'perl-'\n"
          if $alias && $alias =~ /^perl-/;
  
      die "${dist} is not installed\n" unless -d $self->root->perls($dist);
  
      if ( $self->env("PERLBREW_SHELLRC_VERSION") && $self->current_shell_is_bashish ) {
          local $ENV{PERLBREW_PERL} = $dist;
          my $HOME    = $self->env('HOME');
          my $pb_home = $self->home;
  
          $pb_home->mkpath;
          system( "$0 env $dist > " . $pb_home->child("init") );
  
          print "Switched to $dist.\n\n";
      }
      else {
          $self->launch_sub_shell($dist);
      }
  }
  
  sub run_command_off {
      my $self = shift;
      $self->launch_sub_shell;
  }
  
  sub run_command_switch_off {
      my $self    = shift;
      my $pb_home = $self->home;
  
      $pb_home->mkpath;
      system( "env PERLBREW_PERL= $0 env > " . $pb_home->child("init") );
  
      print "\nperlbrew is switched off. Please exit this shell and start a new one to make it effective.\n";
      print
          "To immediately make it effective, run this line in this terminal:\n\n    exec @{[ $self->env('SHELL') ]}\n\n";
  }
  
  sub shell_env {
      my ( $self, $env ) = @_;
      my %env = %$env;
  
      my @statements;
      for my $k ( sort keys %env ) {
          my $v = $env{$k};
          if ( defined($v) && $v ne '' ) {
              $v =~ s/(\\")/\\$1/g;
              push @statements, ["set", $k, $v];
          }
          else {
              push @statements, ["unset", $k];
          }
      }
  
      my $statements = "";
  
      if ( $self->env('SHELL') =~ /(ba|k|z|\/)sh\d?$/ ) {
          for (@statements) {
              my ( $o, $k, $v ) = @$_;
              if ( $o eq 'unset' ) {
                  $statements .= "unset $k\n";
              }
              else {
                  $v =~ s/(\\")/\\$1/g;
                  $statements .= "export $k=\"$v\"\n";
              }
          }
      }
      else {
          for (@statements) {
              my ( $o, $k, $v ) = @$_;
              if ( $o eq 'unset' ) {
                  $statements .= "unsetenv $k\n";
              }
              else {
                  $statements .= "setenv $k \"$v\"\n";
              }
          }
      }
  
      return $statements;
  }
  
  sub run_command_env {
      my ( $self, $name ) = @_;
  
      print $self->shell_env({ $self->perlbrew_env($name) });
  }
  
  sub run_command_symlink_executables {
      my ( $self, @perls ) = @_;
      my $root = $self->root;
  
      unless (@perls) {
          @perls = map { $_->name } grep { -d $_ && !-l $_ } $root->perls->list;
      }
  
      for my $perl (@perls) {
          for my $executable ( $root->perls($perl)->bin->children ) {
              my ( $name, $version ) = $executable =~ m/bin\/(.+?)(5\.\d.*)?$/;
              next unless $version;
  
              $executable->symlink( $root->perls($perl)->bin($name) );
              $executable->symlink( $root->perls($perl)->perl ) if $name eq "cperl";
          }
      }
  }
  
  sub run_command_install_patchperl {
      my ($self) = @_;
      $self->do_install_program_from_url(
          'https://raw.githubusercontent.com/gugod/patchperl-packing/master/patchperl',
          'patchperl',
          sub {
              my ($body) = @_;
              $body =~ s/\A#!.+?\n/ $self->system_perl_shebang . "\n" /se;
              return $body;
          }
      );
  }
  
  sub run_command_install_cpanm {
      my ($self) = @_;
      $self->do_install_program_from_url(
          'https://raw.githubusercontent.com/miyagawa/cpanminus/master/cpanm' => 'cpanm' );
  }
  
  sub run_command_install_cpm {
      my ($self) = @_;
      $self->do_install_program_from_url( 'https://raw.githubusercontent.com/skaji/cpm/main/cpm' => 'cpm' );
  }
  
  sub run_command_self_upgrade {
      my ($self) = @_;
  
      require FindBin;
      unless ( -w $FindBin::Bin ) {
          die "Your perlbrew installation appears to be system-wide.  Please upgrade through your package manager.\n";
      }
  
      my $TMPDIR       = $ENV{TMPDIR} || "/tmp";
      my $TMP_PERLBREW = App::Perlbrew::Path->new( $TMPDIR, "perlbrew" );
  
      http_download( 'https://raw.githubusercontent.com/gugod/App-perlbrew/master/perlbrew', $TMP_PERLBREW );
  
      chmod 0755, $TMP_PERLBREW;
      my $new_version = qx($TMP_PERLBREW version);
      chomp $new_version;
      if ( $new_version =~ /App::perlbrew\/(\d+\.\d+)$/ ) {
          $new_version = $1;
      }
      else {
          $TMP_PERLBREW->unlink;
          die "Unable to detect version of new perlbrew!\n";
      }
  
      if ( $new_version <= $VERSION ) {
          print "Your perlbrew is up-to-date (version $VERSION).\n" unless $self->{quiet};
          $TMP_PERLBREW->unlink;
          return;
      }
  
      print "Upgrading from $VERSION to $new_version\n" unless $self->{quiet};
  
      system $TMP_PERLBREW, "self-install";
      $TMP_PERLBREW->unlink;
  }
  
  sub run_command_uninstall {
      my ( $self, $target ) = @_;
  
      unless ($target) {
          $self->run_command_help("uninstall");
          exit(-1);
      }
  
      my @installed = $self->installed_perls(@_);
  
      my ($to_delete) = grep { $_->{name} eq $target } @installed;
  
      die "'$target' is not installed\n" unless $to_delete;
  
      my @dir_to_delete;
      for ( @{ $to_delete->{libs} } ) {
          push @dir_to_delete, $_->{dir};
      }
      push @dir_to_delete, $to_delete->{dir};
  
      my $ans = ( $self->{yes} ) ? "Y" : undef;
      if ( !defined($ans) ) {
          require ExtUtils::MakeMaker;
          $ans = ExtUtils::MakeMaker::prompt(
              "\nThe following perl+lib installation(s) will be deleted:\n\n\t"
                  . join( "\n\t", @dir_to_delete )
                  . "\n\n... are you sure ? [y/N]",
              "N"
          );
      }
  
      if ( $ans =~ /^Y/i ) {
          for (@dir_to_delete) {
              print "Deleting: $_\n" unless $self->{quiet};
              App::Perlbrew::Path->new($_)->rmpath;
              print "Deleted:  $_\n" unless $self->{quiet};
          }
      }
      else {
          print "\nOK. Not deleting anything.\n\n";
          return;
      }
  }
  
  sub run_command_exec {
      my $self = shift;
      my %opts;
  
      local (@ARGV) = @{ $self->{original_argv} };
  
      Getopt::Long::Configure('require_order');
      my @command_options = ( 'with=s', 'halt-on-error', 'min=s', 'max=s' );
  
      $self->parse_cmdline( \%opts, @command_options );
      shift @ARGV;    # "exec"
      $self->parse_cmdline( \%opts, @command_options );
  
      my @exec_with;
      if ( $opts{with} ) {
          my %installed = map { $_->{name} => $_ } map { ( $_, @{ $_->{libs} } ) } $self->installed_perls;
  
          my $d    = ( $opts{with} =~ m/ / ) ? qr( +) : qr(,+);
          my @with = grep { $_ } map {
              my ( $p, $l ) = $self->resolve_installation_name($_);
              $p .= "\@$l" if $l;
              $p;
          } split $d, $opts{with};
  
          @exec_with = map { $installed{$_} } @with;
      }
      else {
          @exec_with = grep {
              not -l $self->root->perls( $_->{name} );    # Skip Aliases
          } map { ( $_, @{ $_->{libs} } ) } $self->installed_perls;
      }
  
      if ( $opts{min} ) {
  
          # TODO use comparable version.
          # For now, it doesn't produce consistent results for 5.026001 and 5.26.1
          @exec_with = grep { $_->{orig_version} >= $opts{min} } @exec_with;
      }
  
      if ( $opts{max} ) {
          @exec_with = grep { $_->{orig_version} <= $opts{max} } @exec_with;
      }
  
      if ( 0 == @exec_with ) {
          print "No perl installation found.\n" unless $self->{quiet};
      }
  
      my $no_header = 0;
      if ( 1 == @exec_with ) {
          $no_header = 1;
      }
  
      my $overall_success = 1;
      for my $i (@exec_with) {
          my %env = $self->perlbrew_env( $i->{name} );
          next if !$env{PERLBREW_PERL};
  
          local %ENV = %ENV;
          $ENV{$_}       = defined $env{$_} ? $env{$_} : '' for keys %env;
          $ENV{PATH}     = join( ':', $env{PERLBREW_PATH},    $ENV{PATH} );
          $ENV{MANPATH}  = join( ':', $env{PERLBREW_MANPATH}, $ENV{MANPATH} || "" );
          $ENV{PERL5LIB} = $env{PERL5LIB} || "";
  
          print "$i->{name}\n==========\n" unless $no_header || $self->{quiet};
  
          if ( my $err = $self->do_system_with_exit_code(@ARGV) ) {
              my $exit_code = $err >> 8;
  
           # return 255 for case when process was terminated with signal, in that case real exit code is useless and weird
              $exit_code       = 255 if $exit_code > 255;
              $overall_success = 0;
  
              unless ( $self->{quiet} ) {
                  print "Command terminated with non-zero status.\n";
  
                  print STDERR "Command ["
                      . join( ' ', map { /\s/ ? "'$_'" : $_ } @ARGV )
                      .    # trying reverse shell escapes - quote arguments containing spaces
                      "] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n";
                  print STDERR $self->format_info_output;
              }
  
              $self->do_exit_with_error_code($exit_code) if ( $opts{'halt-on-error'} );
          }
          print "\n" unless $self->{quiet} || $no_header;
      }
      $self->do_exit_with_error_code(1) unless $overall_success;
  }
  
  sub run_command_clean {
      my ($self)     = @_;
      my $root       = $self->root;
      my @build_dirs = $root->build->children;
  
      for my $dir (@build_dirs) {
          print "Removing $dir\n";
          App::Perlbrew::Path->new($dir)->rmpath;
      }
  
      my @tarballs = $root->dists->children;
      for my $file (@tarballs) {
          print "Removing $file\n";
          $file->unlink;
      }
  
      print "\nDone\n";
  }
  
  sub run_command_alias {
      my ( $self, $cmd, $name, $alias ) = @_;
  
      unless ($cmd) {
          $self->run_command_help("alias");
          exit(-1);
      }
  
      my $path_name  = $self->root->perls($name)  if $name;
      my $path_alias = $self->root->perls($alias) if $alias;
  
      if ( $alias && -e $path_alias && !-l $path_alias ) {
          die "\nABORT: The installation name `$alias` is not an alias, cannot override.\n\n";
      }
  
      if ( $cmd eq 'create' ) {
          $self->assert_known_installation($name);
  
          if ( $self->is_installed($alias) && !$self->{force} ) {
              die "\nABORT: The installation `${alias}` already exists. Cannot override.\n\n";
          }
  
          $path_alias->unlink;
          $path_name->symlink($path_alias);
      }
      elsif ( $cmd eq 'delete' ) {
          $self->assert_known_installation($name);
  
          unless ( -l $path_name ) {
              die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n";
          }
  
          $path_name->unlink;
      }
      elsif ( $cmd eq 'rename' ) {
          $self->assert_known_installation($name);
  
          unless ( -l $path_name ) {
              die "\nABORT: The installation name `$name` is not an alias, cannot rename.\n\n";
          }
  
          if ( -l $path_alias && !$self->{force} ) {
              die "\nABORT: The alias `$alias` already exists, cannot rename to it.\n\n";
          }
  
          rename( $path_name, $path_alias );
      }
      elsif ( $cmd eq 'help' ) {
          $self->run_command_help("alias");
      }
      else {
          die "\nERROR: Unrecognized action: `${cmd}`.\n\n";
      }
  }
  
  sub run_command_display_bashrc {
      print BASHRC_CONTENT();
  }
  
  sub run_command_display_cshrc {
      print CSHRC_CONTENT();
  }
  
  sub run_command_display_installation_failure_message {
      my ($self) = @_;
  }
  
  sub run_command_lib {
      my ( $self, $subcommand, @args ) = @_;
  
      unless ($subcommand) {
          $self->run_command_help("lib");
          exit(-1);
      }
  
      my $sub = "run_command_lib_$subcommand";
      if ( $self->can($sub) ) {
          $self->$sub(@args);
      }
      else {
          print "Unknown command: $subcommand\n";
      }
  }
  
  sub run_command_lib_create {
      my ( $self, $name ) = @_;
  
      die "ERROR: No lib name\n", $self->run_command_help( "lib", undef, 'return_text' ) unless $name;
  
      $name = $self->enforce_localib($name);
  
      my ( $perl_name, $lib_name ) = $self->resolve_installation_name($name);
  
      if ( !$perl_name ) {
          my ( $perl_name, $lib_name ) = $self->decompose_locallib($name);
          die "ERROR: '$perl_name' is not installed yet, '$name' cannot be created.\n";
      }
  
      my $fullname = $self->compose_locallib( $perl_name, $lib_name );
      my $dir      = $self->home->child( "libs", $fullname );
  
      if ( -d $dir ) {
          die "$fullname is already there.\n";
      }
  
      $dir->mkpath;
  
      print "lib '$fullname' is created.\n" unless $self->{quiet};
  
      return;
  }
  
  sub run_command_lib_delete {
      my ( $self, $name ) = @_;
  
      die "ERROR: No lib to delete\n", $self->run_command_help( "lib", undef, 'return_text' ) unless $name;
  
      $name = $self->enforce_localib($name);
  
      my ( $perl_name, $lib_name ) = $self->resolve_installation_name($name);
  
      my $fullname = $self->compose_locallib( $perl_name, $lib_name );
  
      my $current = $self->current_env;
  
      my $dir = $self->home->child( "libs", $fullname );
  
      if ( -d $dir ) {
  
          if ( $fullname eq $current ) {
              die "$fullname is currently being used in the current shell, it cannot be deleted.\n";
          }
  
          $dir->rmpath;
  
          print "lib '$fullname' is deleted.\n"
              unless $self->{quiet};
      }
      else {
          die "ERROR: '$fullname' does not exist.\n";
      }
  
      return;
  }
  
  sub run_command_lib_list {
      my ($self) = @_;
      my $dir = $self->home->child("libs");
      return unless -d $dir;
  
      opendir my $dh, $dir or die "open $dir failed: $!";
      my @libs = grep { !/^\./ && /\@/ } readdir($dh);
  
      my $current = $self->current_env;
      for (@libs) {
          print $current eq $_ ? "* " : "  ";
          print "$_\n";
      }
  }
  
  sub run_command_upgrade_perl {
      my ($self) = @_;
  
      my $PERL_VERSION_RE = qr/(\d+)\.(\d+)\.(\d+)/;
  
      my ($current) = grep { $_->{is_current} } $self->installed_perls;
  
      unless ( defined $current ) {
          print "no perlbrew environment is currently in use\n";
          exit(1);
      }
  
      my ( $major, $minor, $release );
  
      if ( $current->{version} =~ /^$PERL_VERSION_RE$/ ) {
          ( $major, $minor, $release ) = ( $1, $2, $3 );
      }
      else {
          print "unable to parse version '$current->{version}'\n";
          exit(1);
      }
  
      my @available = grep { /^perl-$major\.$minor/ } $self->available_perls;
  
      my $latest_available_perl = $release;
  
      foreach my $perl (@available) {
          if ( $perl =~ /^perl-$PERL_VERSION_RE$/ ) {
              my $this_release = $3;
              if ( $this_release > $latest_available_perl ) {
                  $latest_available_perl = $this_release;
              }
          }
      }
  
      if ( $latest_available_perl == $release ) {
          print "This perlbrew environment ($current->{name}) is already up-to-date.\n";
          exit(0);
      }
  
      my $dist_version = "$major.$minor.$latest_available_perl";
      my $dist         = "perl-$dist_version";
  
      print "Upgrading $current->{name} to $dist_version\n" unless $self->{quiet};
      local $self->{as}        = $current->{name};
      local $self->{dist_name} = $dist;
  
      my @d_options  = map { '-D' . $flavor{$_}->{d_option} } keys %flavor;
      my %sub_config = map { $_ => $Config{$_} } grep { /^config_arg\d/ } keys %Config;
      for my $value ( values %sub_config ) {
          my $value_wo_D = $value;
          $value_wo_D =~ s/^-D//;
          push @{ $self->{D} }, $value_wo_D if grep { /$value/ } @d_options;
      }
  
      $self->do_install_release( $dist, $dist_version );
  }
  
  sub list_modules {
      my ( $self, $env ) = @_;
  
      $env ||= $self->current_env;
      my ( $stdout, $stderr, $success ) = Capture::Tiny::capture(
          sub {
              __PACKAGE__->new( "--quiet", "exec", "--with", $env, 'perl', '-MExtUtils::Installed', '-le',
                  'BEGIN{@INC=grep {$_ ne q!.!} @INC}; print for ExtUtils::Installed->new->modules;',
              )->run;
          }
      );
  
      unless ($success) {
          unless ( $self->{quiet} ) {
              print STDERR "Failed to retrive the list of installed modules.\n";
              if ( $self->{verbose} ) {
                  print STDERR "STDOUT\n======\n$stdout\nSTDERR\n======\n$stderr\n";
              }
          }
          return [];
      }
  
      my %rename = (
          "ack"                    => "App::Ack",
          "libwww::perl"           => "LWP",
          "libintl-perl"           => "Locale::Messages",
          "Role::Identifiable"     => "Role::Identifiable::HasTags",
          "TAP::Harness::Multiple" => "TAP::Harness::ReportByDescription",
      );
  
      return [map { $rename{$_} || $_ } grep { $_ ne "Perl" } split( /\n/, $stdout )];
  }
  
  sub run_command_list_modules {
      my ($self) = @_;
      my ( $modules, $error ) = $self->list_modules();
      print "$_\n" for @$modules;
  }
  
  sub resolve_installation_name {
      my ( $self, $name ) = @_;
      die "App::perlbrew->resolve_installation_name requires one argument." unless $name;
  
      my ( $perl_name, $lib_name ) = $self->decompose_locallib($name);
      $perl_name = $name unless $lib_name;
      $perl_name ||= $self->current_perl;
  
      if ( !$self->is_installed($perl_name) ) {
          if ( $self->is_installed("perl-${perl_name}") ) {
              $perl_name = "perl-${perl_name}";
          }
          else {
              return undef;
          }
      }
  
      return wantarray ? ( $perl_name, $lib_name ) : $perl_name;
  }
  
  # Implementation of the 'clone-modules' command.
  #
  # This method accepts a destination and source installation
  # of Perl to clone modules from and into.
  # For instance calling
  # $app->run_command_clone_modules($perl_a, $perl_b);
  # installs all modules that have been installed on Perl A
  # to the instance of Perl B.
  # The source instance is optional, that is if the method
  # is invoked with a single argument, the currently
  # running instance is used as source. Therefore the
  # two following calls are the same:
  #
  # $app->run_command_clone_modules( $self->current_perl, $perl_b );
  # $app->run_command_clone_modules( $perl_b );
  #
  # Of course, both Perl installation must exist on this
  # perlbrew enviroment.
  #
  # The method extracts the modules installed on the source Perl
  # instance and put them on a temporary file, such file is then
  # passed to another instance of the application to
  # execute cpanm on it. The final result is the installation
  # of source modules into the destination instance.
  sub run_command_clone_modules {
      my $self = shift;
  
      # default to use the currently installation
      my ( $dst_perl, $src_perl );
  
      # the first argument is the destination, the second
      # optional argument is the source version, default
      # to use the current installation
      $dst_perl = pop || $self->current_env;
      $src_perl = pop || $self->current_env;
  
      # check source and destination do exist
      undef $src_perl if ( !$self->resolve_installation_name($src_perl) );
      undef $dst_perl if ( !$self->resolve_installation_name($dst_perl) );
  
      if (   !$src_perl
          || !$dst_perl
          || $src_perl eq $dst_perl )
      {
          # cannot understand from where to where or
          # the user did specify the same versions
          $self->run_command_help('clone-modules');
          exit(-1);
      }
  
      my @modules_to_install = @{ $self->list_modules($src_perl) };
  
      unless (@modules_to_install) {
          print "\nNo modules installed on $src_perl !\n" unless $self->{quiet};
          return;
      }
  
      print "\nInstalling $#modules_to_install modules from $src_perl to $dst_perl ...\n"
          unless $self->{quiet};
  
      # create a new application to 'exec' the 'cpanm'
      # with the specified module list
  
      my @args = ( qw(--quiet exec --with), $dst_perl, 'cpanm' );
      push @args, '--notest' if $self->{notest};
      push @args, @modules_to_install;
  
      __PACKAGE__->new(@args)->run;
  }
  
  sub format_info_output {
      my ( $self, $module ) = @_;
  
      my $out = '';
  
      $out .= "Current perl:\n";
      if ( $self->current_perl ) {
          $out .= "  Name: " . $self->current_env . "\n";
          $out .= "  Path: " . $self->installed_perl_executable( $self->current_perl ) . "\n";
          $out .= "  Config: " . $self->configure_args( $self->current_perl ) . "\n";
          $out .= join(
              '',
              "  Compiled at: ",
              (
                  map { /  Compiled at (.+)\n/ ? $1 : () }
                      `@{[ $self->installed_perl_executable($self->current_perl) ]} -V`
              ),
              "\n"
          );
      }
      else {
          $out .= "Using system perl." . "\n";
          $out .= "Shebang: " . $self->system_perl_shebang . "\n";
      }
  
      $out .= "\nperlbrew:\n";
      $out .= "  version: " . $self->VERSION . "\n";
      $out .= "  ENV:\n";
      for ( map { "PERLBREW_$_" } qw(ROOT HOME PATH MANPATH) ) {
          $out .= "    $_: " . ( $self->env($_) || "" ) . "\n";
      }
  
      if ($module) {
          my $code =
  qq{eval "require $module" and do { (my \$f = "$module") =~ s<::></>g; \$f .= ".pm"; print "$module\n  Location: \$INC{\$f}\n  Version: " . ($module->VERSION ? $module->VERSION : "no VERSION specified" ) } or do { print "$module could not be found, is it installed?" } };
          $out .=
              "\nModule: " . $self->do_capture( $self->installed_perl_executable( $self->current_perl ), "-le", $code );
      }
  
      $out;
  }
  
  sub run_command_info {
      my ($self) = shift;
      print $self->format_info_output(@_);
  }
  
  sub run_command_make_shim {
      my ($self, $program) = @_;
  
      unless ($program) {
          $self->run_command_help("make-shim");
          return;
      }
  
      my $output = $self->{output} || $program;
  
      if (-f $output) {
          die "ERROR: $program already exists under current directory.\n";
      }
  
      my $current_env = $self->current_env
          or die "ERROR: perlbrew is not activated. make-shim requires an perlbrew environment to be activated.\nRead the usage by running: perlbrew help make-shim\n";
  
      my %env = $self->perlbrew_env( $current_env );
  
      my $shebang = '#!' . $self->env('SHELL');
      my $preemble = $self->shell_env(\%env);
      my $path = $self->shell_env({ PATH => $env{"PERLBREW_PATH"} . ":" . $self->env("PATH") });
      my $shim = join(
          "\n",
          $shebang,
          $preemble,
          $path,
          'exec ' . $program . ' "$@"',
          "\n"
      );
  
      open my $fh, ">", "$output" or die $!;
      print $fh $shim;
      close $fh;
      chmod 0755, $output;
  
      if ( $self->{verbose} ) {
          print "The shim $output is made.\n";
      }
  }
  
  sub run_command_make_pp {
      my ($self, $program) = @_;
  
      unless ($program) {
          $self->run_command_help("make-pp");
          return;
      }
  
      my $current_env = $self->current_env
          or die "ERROR: perlbrew is not activated. make-pp requires an perlbrew environment to be activated.\nRead the usage by running: perlbrew help make-pp\n";
  
      my $output = $self->{output} || $program;
  
      if (-f $output) {
          die "ERROR: $program already exists under current directory.\n";
      }
  
      my $path_program = $self->whereis_in_env($program, $current_env)
          or die "ERROR: $program cannot be found in $current_env";
      my $path_pp = $self->whereis_in_env("pp", $current_env)
              or die "ERROR: pp cannot be found in $current_env";
  
  
      my $sitelib = $self->do_capture(
          $self->installed_perl_executable( $self->current_perl ),
          "-MConfig",
          "-e",
          'print $Config{sitelibexp}',
      );
  
      my $locallib;
      if ($self->current_lib) {
          require local::lib;
          my ($current_lib) = grep { $_->{is_current} } $self->local_libs();
          my @llpaths = sort { length($a) <=> length($b) }
              local::lib->lib_paths_for( $current_lib->{dir} );
          $locallib = $llpaths[0];
      }
  
      my $perlversion = $self->do_capture(
          $self->installed_perl_executable( $self->current_perl ),
          "-MConfig",
          "-e",
          'print $Config{version}',
      );
  
      my @cmd = (
          $path_pp,
          "-B", # core modules
          "-a", "$sitelib;$perlversion",
          ($locallib ? ("-a", "$locallib;$perlversion") : ()),
          "-z", "9",
          "-o", $output,
          $path_program,
      );
  
      $self->do_system(@cmd);
  }
  
  sub whereis_in_env {
      my ($self, $program, $env) = @_;
      my %env = $self->perlbrew_env( $env );
      my @paths = split /:/, $env{PERLBREW_PATH};
  
      my ($path) = grep { -x $_ } map { App::Perlbrew::Path->new($_, $program) } @paths;
  
      return $path;
  }
  
  
  sub BASHRC_CONTENT() {
      return
            "export PERLBREW_SHELLRC_VERSION=$VERSION\n"
          . ( exists $ENV{PERLBREW_ROOT} ? "export PERLBREW_ROOT=$PERLBREW_ROOT\n" : "" ) . "\n"
          . <<'RC';
  
  __perlbrew_reinit() {
      if [[ ! -d "$PERLBREW_HOME" ]]; then
          mkdir -p "$PERLBREW_HOME"
      fi
  
      [ -f "$PERLBREW_HOME/init" ] && rm "$PERLBREW_HOME/init"
      echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init"
      command perlbrew env $1 | \grep PERLBREW_ >> "$PERLBREW_HOME/init"
      . "$PERLBREW_HOME/init"
      __perlbrew_set_path
  }
  
  __perlbrew_purify () {
      local path patharray outsep
      IFS=: read -r${BASH_VERSION+a}${ZSH_VERSION+A} patharray <<< "$1"
      for path in "${patharray[@]}" ; do
          case "$path" in
              (*"$PERLBREW_HOME"*) ;;
              (*"$PERLBREW_ROOT"*) ;;
              (*) printf '%s' "$outsep$path" ; outsep=: ;;
          esac
      done
  }
  
  __perlbrew_set_path () {
      export MANPATH=${PERLBREW_MANPATH:-}${PERLBREW_MANPATH:+:}$(__perlbrew_purify "$(manpath 2>/dev/null)")
      export PATH=${PERLBREW_PATH:-$PERLBREW_ROOT/bin}:$(__perlbrew_purify "$PATH")
      hash -r
  }
  
  __perlbrew_set_env() {
      local code
      code="$($perlbrew_command env $@)" || return $?
      eval "$code"
  }
  
  __perlbrew_activate() {
      [[ -n $(alias perl 2>/dev/null) ]] && unalias perl 2>/dev/null
  
      if [[ -n "${PERLBREW_PERL:-}" ]]; then
            __perlbrew_set_env "${PERLBREW_PERL:-}${PERLBREW_LIB:+@}$PERLBREW_LIB"
      fi
  
      __perlbrew_set_path
  }
  
  __perlbrew_deactivate() {
      __perlbrew_set_env
      unset PERLBREW_PERL
      unset PERLBREW_LIB
      __perlbrew_set_path
  }
  
  perlbrew () {
      local exit_status
      local short_option
      export SHELL
  
      if [[ $1 == -* ]]; then
          short_option=$1
          shift
      else
          short_option=""
      fi
  
      case $1 in
          (use)
              if [[ -z "$2" ]] ; then
                  echo -n "Currently using ${PERLBREW_PERL:-system perl}"
                  [ -n "$PERLBREW_LIB" ] && echo -n "@$PERLBREW_LIB"
                  echo
              else
                  __perlbrew_set_env "$2" && { __perlbrew_set_path ; true ; }
                  exit_status="$?"
              fi
              ;;
  
          (switch)
                if [[ -z "$2" ]] ; then
                    command perlbrew switch
                else
                    perlbrew use $2 && { __perlbrew_reinit $2 ; true ; }
                    exit_status=$?
                fi
                ;;
  
          (off)
              __perlbrew_deactivate
              echo "perlbrew is turned off."
              ;;
  
          (switch-off)
              __perlbrew_deactivate
              __perlbrew_reinit
              echo "perlbrew is switched off."
              ;;
  
          (*)
              command perlbrew $short_option "$@"
              exit_status=$?
              ;;
      esac
      hash -r
      return ${exit_status:-0}
  }
  
  [[ -z "${PERLBREW_ROOT:-}" ]] && export PERLBREW_ROOT="$HOME/perl5/perlbrew"
  [[ -z "${PERLBREW_HOME:-}" ]] && export PERLBREW_HOME="$HOME/.perlbrew"
  
  if [[ ! -n "${PERLBREW_SKIP_INIT:-}" ]]; then
      if [[ -f "${PERLBREW_HOME:-}/init" ]]; then
          . "$PERLBREW_HOME/init"
      fi
  fi
  
  if [[ -f "${PERLBREW_ROOT:-}/bin/perlbrew" ]]; then
      perlbrew_command="${PERLBREW_ROOT:-}/bin/perlbrew"
  else
      perlbrew_command="perlbrew"
  fi
  
  __perlbrew_activate
  
  RC
  
  }
  
  sub BASH_COMPLETION_CONTENT() {
      return <<'COMPLETION';
  if [[ -n ${ZSH_VERSION-} ]]; then
      autoload -U +X bashcompinit && bashcompinit
  fi
  
  export PERLBREW="command perlbrew"
  _perlbrew_compgen()
  {
      COMPREPLY=( $($PERLBREW compgen $COMP_CWORD ${COMP_WORDS[*]}) )
  }
  complete -F _perlbrew_compgen perlbrew
  COMPLETION
  }
  
  sub PERLBREW_FISH_CONTENT {
      return "set -x PERLBREW_SHELLRC_VERSION $VERSION\n" . <<'END';
  
  function __perlbrew_reinit
      if not test -d "$PERLBREW_HOME"
          mkdir -p "$PERLBREW_HOME"
      end
  
      echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init"
      command perlbrew env $argv[1] | \grep PERLBREW_ >> "$PERLBREW_HOME/init"
      __source_init
      __perlbrew_set_path
  end
  
  function __perlbrew_set_path
      set -l MANPATH_WITHOUT_PERLBREW (perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);')
  
      if test -n "$PERLBREW_MANPATH"
          set -l PERLBREW_MANPATH $PERLBREW_MANPATH":"
          set -x MANPATH {$PERLBREW_MANPATH}{$MANPATH_WITHOUT_PERLBREW}
      else
          set -x MANPATH $MANPATH_WITHOUT_PERLBREW
      end
  
      set -l PATH_WITHOUT_PERLBREW (eval $perlbrew_command display-pristine-path | perl -pe'y/:/ /')
  
      # silencing stderr in case there's a non-existent path in $PATH (see GH#446)
      if test -n "$PERLBREW_PATH"
          set -x PERLBREW_PATH (echo $PERLBREW_PATH | perl -pe 'y/:/ /' )
          eval set -x PATH $PERLBREW_PATH $PATH_WITHOUT_PERLBREW 2> /dev/null
      else
          eval set -x PATH $PERLBREW_ROOT/bin $PATH_WITHOUT_PERLBREW 2> /dev/null
      end
  end
  
  function __perlbrew_set_env
      set -l code (eval $perlbrew_command env $argv | perl -pe 's/^(export|setenv)/set -xg/; s/=/ /; s/^unset(env)* (.*)/if test -n "\$$2"; set -eg $2; end/; s/$/;/; y/:/ /')
  
      if test -z "$code"
          return 0;
      else
          eval $code
      end
  end
  
  function __perlbrew_activate
      functions -e perl
  
      if test -n "$PERLBREW_PERL"
          if test -z "$PERLBREW_LIB"
              __perlbrew_set_env $PERLBREW_PERL
          else
              __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB
          end
      end
  
      __perlbrew_set_path
  end
  
  function __perlbrew_deactivate
      __perlbrew_set_env
      set -x PERLBREW_PERL
      set -x PERLBREW_LIB
      set -x PERLBREW_PATH
      __perlbrew_set_path
  end
  
  function perlbrew
  
      test -z "$argv"
      and echo "    Usage: perlbrew <command> [options] [arguments]"
      and echo "       or: perlbrew help"
      and return 1
  
      switch $argv[1]
          case use
              if test ( count $argv ) -eq 1
                  if test -z "$PERLBREW_PERL"
                      echo "Currently using system perl"
                  else
                      echo "Currently using $PERLBREW_PERL"
                  end
              else
                  __perlbrew_set_env $argv[2]
                  if test "$status" -eq 0
                      __perlbrew_set_path
                  end
              end
  
          case switch
              if test ( count $argv ) -eq 1
                  command perlbrew switch
              else
                  perlbrew use $argv[2]
                  if test "$status" -eq 0
                      __perlbrew_reinit $argv[2]
                  end
              end
  
          case off
              __perlbrew_deactivate
              echo "perlbrew is turned off."
  
          case switch-off
              __perlbrew_deactivate
              __perlbrew_reinit
              echo "perlbrew is switched off."
  
          case '*'
              command perlbrew $argv
      end
  end
  
  function __source_init
      perl -pe 's/^(export|setenv)/set -xg/; s/^unset(env)* (.*)/if test -n "\$$2"; set -eg $2; end/; s/=/ /; s/$/;/;' "$PERLBREW_HOME/init" | source
  end
  
  if test -z "$PERLBREW_ROOT"
      set -x PERLBREW_ROOT "$HOME/perl5/perlbrew"
  end
  
  if test -z "$PERLBREW_HOME"
      set -x PERLBREW_HOME "$HOME/.perlbrew"
  end
  
  if test -z "$PERLBREW_SKIP_INIT" -a -f "$PERLBREW_HOME/init"
      __source_init
  end
  
  set perlbrew_bin_path "$PERLBREW_ROOT/bin"
  
  if test -f "$perlbrew_bin_path/perlbrew"
      set perlbrew_command "$perlbrew_bin_path/perlbrew"
  else
      set perlbrew_command perlbrew
  end
  
  set -e perlbrew_bin_path
  
  __perlbrew_activate
  
  ## autocomplete stuff #############################################
  
  function __fish_perlbrew_needs_command
    set cmd (commandline -opc)
    if test (count $cmd) -eq 1 -a $cmd[1] = 'perlbrew'
      return 0
    end
    return 1
  end
  
  function __fish_perlbrew_using_command
    set cmd (commandline -opc)
    if test (count $cmd) -gt 1
      if [ $argv[1] = $cmd[2] ]
        return 0
      end
    end
  end
  
  for com in (perlbrew help | perl -ne'print lc if s/^COMMAND:\s+//')
      complete -f -c perlbrew -n '__fish_perlbrew_needs_command' -a $com
  end
  
  for com in switch use;
      complete -f -c perlbrew -n "__fish_perlbrew_using_command $com" \
          -a '(perlbrew list | perl -pe\'s/\*?\s*(\S+).*/$1/\')'
  end
  
  END
  }
  
  sub CSH_WRAPPER_CONTENT {
      return <<'WRAPPER';
  set perlbrew_exit_status=0
  
  if ( "$1" =~ -* ) then
      set perlbrew_short_option="$1"
      shift
  else
      set perlbrew_short_option=""
  endif
  
  switch ( "$1" )
      case use:
          if ( $%2 == 0 ) then
              if ( $?PERLBREW_PERL == 0 ) then
                  echo "Currently using system perl"
              else
                  if ( $%PERLBREW_PERL == 0 ) then
                      echo "Currently using system perl"
                  else
                      echo "Currently using $PERLBREW_PERL"
                  endif
              endif
          else
              set perlbrew_line_count=0
              foreach perlbrew_line ( "`\perlbrew env $2:q`" )
                  eval "$perlbrew_line"
                  @ perlbrew_line_count++
              end
              if ( $perlbrew_line_count == 0 ) then
                  set perlbrew_exit_status=1
              else
                  source "$PERLBREW_ROOT/etc/csh_set_path"
              endif
          endif
          breaksw
  
      case switch:
          if ( $%2 == 0 ) then
              \perlbrew switch
          else
              perlbrew use "$2" && source "$PERLBREW_ROOT/etc/csh_reinit" "$2"
          endif
          breaksw
  
      case off:
          unsetenv PERLBREW_PERL
          foreach perlbrew_line ( "`\perlbrew env`" )
              eval "$perlbrew_line"
          end
          source "$PERLBREW_ROOT/etc/csh_set_path"
          echo "perlbrew is turned off."
          breaksw
  
      case switch-off:
          unsetenv PERLBREW_PERL
          source "$PERLBREW_ROOT/etc/csh_reinit" ''
          echo "perlbrew is switched off."
          breaksw
  
      default:
          \perlbrew $perlbrew_short_option:q $argv:q
          set perlbrew_exit_status=$?
          breaksw
  endsw
  rehash
  exit $perlbrew_exit_status
  WRAPPER
  }
  
  sub CSH_REINIT_CONTENT {
      return <<'REINIT';
  if ( ! -d "$PERLBREW_HOME" ) then
      mkdir -p "$PERLBREW_HOME"
  endif
  
  echo '# DO NOT EDIT THIS FILE' >! "$PERLBREW_HOME/init"
  \perlbrew env $1 >> "$PERLBREW_HOME/init"
  source "$PERLBREW_HOME/init"
  source "$PERLBREW_ROOT/etc/csh_set_path"
  REINIT
  }
  
  sub CSH_SET_PATH_CONTENT {
      return <<'SETPATH';
  unalias perl
  
  if ( $?PERLBREW_PATH == 0 ) then
      setenv PERLBREW_PATH "$PERLBREW_ROOT/bin"
  endif
  
  setenv PATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,$ENV{PATH};'`
  setenv PATH "${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW}"
  
  setenv MANPATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,qx(manpath 2> /dev/null);'`
  if ( $?PERLBREW_MANPATH == 1 ) then
      setenv MANPATH "${PERLBREW_MANPATH}:${MANPATH_WITHOUT_PERLBREW}"
  else
      setenv MANPATH "${MANPATH_WITHOUT_PERLBREW}"
  endif
  SETPATH
  }
  
  sub CSHRC_CONTENT {
      return "setenv PERLBREW_SHELLRC_VERSION $VERSION\n\n" . <<'CSHRC';
  
  if ( $?PERLBREW_HOME == 0 ) then
      setenv PERLBREW_HOME "$HOME/.perlbrew"
  endif
  
  if ( $?PERLBREW_ROOT == 0 ) then
      setenv PERLBREW_ROOT "$HOME/perl5/perlbrew"
  endif
  
  if ( $?PERLBREW_SKIP_INIT == 0 ) then
      if ( -f "$PERLBREW_HOME/init" ) then
          source "$PERLBREW_HOME/init"
      endif
  endif
  
  if ( $?PERLBREW_PATH == 0 ) then
      setenv PERLBREW_PATH "$PERLBREW_ROOT/bin"
  endif
  
  source "$PERLBREW_ROOT/etc/csh_set_path"
  alias perlbrew 'source "$PERLBREW_ROOT/etc/csh_wrapper"'
  CSHRC
  
  }
  
  sub append_log {
      my ( $self, $message ) = @_;
      my $log_handler;
      open( $log_handler, '>>', $self->{log_file} )
          or die "Cannot open log file for appending: $!";
      print $log_handler "$message\n";
      close($log_handler);
  }
  
  sub INSTALLATION_FAILURE_MESSAGE {
      my ($self) = @_;
      return <<FAIL;
  Installation process failed. To spot any issues, check
  
    $self->{log_file}
  
  If some perl tests failed and you still want to install this distribution anyway,
  do:
  
    (cd $self->{dist_extracted_dir}; make install)
  
  You might also want to try upgrading patchperl before trying again:
  
    perlbrew install-patchperl
  
  Generally, if you need to install a perl distribution known to have minor test
  failures, do one of these commands to avoid seeing this message:
  
    perlbrew --notest install $self->{dist_name}
    perlbrew --force install $self->{dist_name}
  
  FAIL
  
  }
  
  1;
  
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  App::perlbrew - Manage perl installations in your C<$HOME>
  
  =head1 SYNOPSIS
  
      # Installation
      curl -L https://install.perlbrew.pl | bash
  
      # Initialize
      perlbrew init
  
      # See what is available
      perlbrew available
  
      # Install some Perls
      perlbrew install 5.32.1
      perlbrew install perl-5.28.3
      perlbrew install perl-5.33.6
  
      # See what were installed
      perlbrew list
  
      # Swith to an installation and set it as default
      perlbrew switch perl-5.32.1
  
      # Temporarily use another version only in current shell.
      perlbrew use perl-5.28.3
      perl -v
  
      # Turn it off and go back to the system perl.
      perlbrew off
  
      # Turn it back on with 'switch', or 'use'
      perlbrew switch perl-5.32.1
      perlbrew use perl-5.32.1
  
      # Exec something with all perlbrew-ed perls
      perlbrew exec -- perl -E 'say $]'
  
  =head1 DESCRIPTION
  
  L<perlbrew> is a program to automate the building and installation of perl in an
  easy way. It provides multiple isolated perl environments, and a mechanism
  for you to switch between them.
  
  Everything are installed unter C<~/perl5/perlbrew>. You then need to include a
  bashrc/cshrc provided by perlbrew to tweak the PATH for you. You then can
  benefit from not having to run C<sudo> commands to install
  cpan modules because those are installed inside your C<HOME> too.
  
  For the documentation of perlbrew usage see L<perlbrew> command
  on L<MetaCPAN|https://metacpan.org/>, or by running C<perlbrew help>,
  or by visiting L<perlbrew's official website|https://perlbrew.pl/>. The following documentation
  features the API of C<App::perlbrew> module, and may not be remotely
  close to what your want to read.
  
  =head1 INSTALLATION
  
  It is the simplest to use the perlbrew installer, just paste this statement to
  your terminal:
  
      curl -L https://install.perlbrew.pl | bash
  
  Or this one, if you have C<fetch> (default on FreeBSD):
  
      fetch -o- https://install.perlbrew.pl | sh
  
  After that, C<perlbrew> installs itself to C<~/perl5/perlbrew/bin>, and you
  should follow the instruction on screen to modify your shell rc file to put it
  in your PATH.
  
  The installed perlbrew command is a standalone executable that can be run with
  system perl. The minimum required version of system perl is 5.8.0, which should
  be good enough for most of the OSes these days.
  
  A fat-packed version of L<patchperl> is also installed to
  C<~/perl5/perlbrew/bin>, which is required to build old perls.
  
  The directory C<~/perl5/perlbrew> will contain all install perl executables,
  libraries, documentations, lib, site_libs. In the documentation, that directory
  is referred as C<perlbrew root>. If you need to set it to somewhere else because,
  say, your C<HOME> has limited quota, you can do that by setting C<PERLBREW_ROOT>
  environment variable before running the installer:
  
      export PERLBREW_ROOT=/opt/perl5
      curl -L https://install.perlbrew.pl | bash
  
  As a result, different users on the same machine can all share the same perlbrew
  root directory (although only original user that made the installation would
  have the permission to perform perl installations.)
  
  You may also install perlbrew from CPAN:
  
      cpan App::perlbrew
  
  In this case, the perlbrew command is installed as C</usr/bin/perlbrew> or
  C</usr/local/bin/perlbrew> or others, depending on the location of your system
  perl installation.
  
  Please make sure not to run this with one of the perls brewed with
  perlbrew. It's the best to turn perlbrew off before you run that, if you're
  upgrading.
  
      perlbrew off
      cpan App::perlbrew
  
  You should always use system cpan (like /usr/bin/cpan) to install
  C<App::perlbrew> because it will be installed under a system PATH like
  C</usr/bin>, which is not affected by perlbrew C<switch> or C<use> command.
  
  The C<self-upgrade> command will not upgrade the perlbrew installed by cpan
  command, but it is also easy to upgrade perlbrew by running C<cpan App::perlbrew>
  again.
  
  =head1 PROJECT DEVELOPMENT
  
  L<perlbrew project|https://perlbrew.pl/> uses github
  L<https://github.com/gugod/App-perlbrew/issues> for issue
  tracking. Issues sent to these two systems will eventually be reviewed
  and handled. To participate, you need a github account.
  
  Please briefly read the short instructions about how to get your work
  released to CPAN:
  
  L<https://github.com/gugod/App-perlbrew/blob/develop/CONTRIBUTING.md>
  
  =head1 AUTHOR
  
  Kang-min Liu  C<< <gugod@gugod.org> >>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2023 Kang-min Liu C<< <gugod@gugod.org> >>.
  
  =head1 LICENCE
  
  The MIT License
  
  =head1 DISCLAIMER OF WARRANTY
  
  BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
  FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
  OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
  PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
  EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
  ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
  YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
  NECESSARY SERVICING, REPAIR, OR CORRECTION.
  
  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
  WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
  REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
  LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
  OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
  THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
  RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
  FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
  SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
  SUCH DAMAGES.
  
  =cut
APP_PERLBREW

$fatpacked{"CPAN/Perl/Releases.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_PERL_RELEASES';
  package CPAN::Perl::Releases;
  $CPAN::Perl::Releases::VERSION = '5.20230720';
  #ABSTRACT: Mapping Perl releases on CPAN to the location of the tarballs
  
  use strict;
  use warnings;
  use vars qw[@ISA @EXPORT_OK];
  
  use Exporter;
  
  @ISA       = qw(Exporter);
  @EXPORT_OK = qw(perl_tarballs perl_versions perl_pumpkins);
  
  # Data gathered from using findlinks.pl script in this dists tools/
  # directory, run over the src/5.0 of a local CPAN mirror.
  our $cache = { };
  our $data =
  {
  "5.004" => { id => 'CHIPS' },
  "5.004_01" => { id => 'TIMB' },
  "5.004_02" => { id => 'TIMB' },
  "5.004_03" => { id => 'TIMB' },
  "5.004_04" => { id => 'TIMB' },
  "5.004_05" => { id => 'CHIPS' },
  "5.005" => { id => 'GSAR' },
  "5.005_01" => { id => 'GSAR' },
  "5.005_02" => { id => 'GSAR' },
  "5.005_03" => { id => 'GBARR' },
  "5.005_04" => { id => 'LBROCARD' },
  "5.6.0" => { id => 'GSAR' },
  "5.6.1-TRIAL1" => { id => 'GSAR' },
  "5.6.1-TRIAL2" => { id => 'GSAR' },
  "5.6.1-TRIAL3" => { id => 'GSAR' },
  "5.6.1" => { id => 'GSAR' },
  "5.6.2" => { id => 'RGARCIA' },
  "5.7.0" => { id => 'JHI' },
  "5.7.2" => { id => 'JHI' },
  "5.7.3" => { id => 'JHI' },
  "5.8.0" => { id => 'JHI' },
  "5.8.1" => { id => 'JHI' },
  "5.8.2" => { id => 'NWCLARK' },
  "5.8.3" => { id => 'NWCLARK' },
  "5.8.4" => { id => 'NWCLARK' },
  "5.8.5" => { id => 'NWCLARK' },
  "5.8.6" => { id => 'NWCLARK' },
  "5.8.7" => { id => 'NWCLARK' },
  "5.8.8" => { id => 'NWCLARK' },
  "5.8.9" => { id => 'NWCLARK' },
  "5.9.0" => { id => 'HVDS' },
  "5.9.1" => { id => 'RGARCIA' },
  "5.9.2" => { id => 'RGARCIA' },
  "5.9.3" => { id => 'RGARCIA' },
  "5.9.4" => { id => 'RGARCIA' },
  "5.9.5" => { id => 'RGARCIA' },
  "5.10.0" => { id => 'RGARCIA' },
  "5.10.1" => { id => 'DAPM' },
  "5.11.0" => { id => 'JESSE' },
  "5.11.1" => { id => 'JESSE' },
  "5.11.2" => { id => 'LBROCARD' },
  "5.11.3" => { id => 'JESSE' },
  "5.11.5" => { id => 'SHAY' },
  "5.12.0" => { id => 'JESSE' },
  "5.12.1" => { id => 'JESSE' },
  "5.12.2" => { id => 'JESSE' },
  "5.12.3" => { id => 'RJBS' },
  "5.12.4" => { id => 'LBROCARD' },
  "5.12.5" => { id => 'DOM' },
  "5.13.0" => { id => 'LBROCARD' },
  "5.13.2" => { id => 'MSTROUT' },
  "5.13.3" => { id => 'DAGOLDEN' },
  "5.13.4" => { id => 'FLORA' },
  "5.13.5" => { id => 'SHAY' },
  "5.13.6" => { id => 'MIYAGAWA' },
  "5.13.7" => { id => 'BINGOS' },
  "5.13.8" => { id => 'ZEFRAM' },
  "5.13.9" => { id => 'JESSE' },
  "5.13.10" => { id => 'AVAR' },
  "5.13.11" => { id => 'FLORA' },
  "5.14.0" => { id => 'JESSE' },
  "5.14.1" => { id => 'JESSE' },
  "5.14.2-RC1" => { id => 'FLORA' },
  "5.14.2" => { id => 'FLORA' },
  "5.14.3" => { id => 'DOM' },
  "5.14.4-RC1" => { id => 'DAPM' },
  "5.14.4-RC2" => { id => 'DAPM' },
  "5.14.4" => { id => 'DAPM' },
  "5.15.0" => { id => 'DAGOLDEN' },
  "5.15.1" => { id => 'ZEFRAM' },
  "5.15.3" => { id => 'STEVAN' },
  "5.15.4" => { id => 'FLORA' },
  "5.15.5" => { id => 'SHAY' },
  "5.15.6" => { id => 'DROLSKY' },
  "5.15.7" => { id => 'BINGOS' },
  "5.15.9" => { id => 'ABIGAIL' },
  "5.16.0" => { id => 'RJBS' },
  "5.16.1" => { id => 'RJBS' },
  "5.16.2" => { id => 'RJBS' },
  "5.16.3" => { id => 'RJBS' },
  "5.17.0" => { id => 'ZEFRAM' },
  "5.17.1" => { id => 'DOY' },
  "5.17.2" => { id => 'TONYC' },
  "5.17.3" => { id => 'SHAY' },
  "5.17.4" => { id => 'FLORA' },
  "5.17.5" => { id => 'FLORA' },
  "5.17.7" => { id => 'DROLSKY' },
  "5.17.8" => { id => 'ARC' },
  "5.17.9" => { id => 'BINGOS' },
  "5.18.0" => { id => 'RJBS' },
  "5.18.1" => { id => 'RJBS' },
  "5.19.1" => { id => 'DAGOLDEN' },
  "5.19.3" => { id => 'SHAY' },
  "5.19.4" => { id => 'SHAY' },
  "5.19.5" => { id => 'SHAY' },
  "5.19.6" => { id => 'BINGOS' },
  "5.19.7" => { id => 'ABIGAIL' },
  "5.18.2" => { id => 'RJBS' },
  "5.19.9" => { id => 'TONYC' },
  "5.19.10" => { id => 'ARC' },
  "5.19.11" => { id => 'SHAY' },
  "5.20.0" => { id => 'RJBS' },
  "5.21.1" => { id => 'WOLFSAGE' },
  "5.21.2" => { id => 'ABIGAIL' },
  "5.21.3" => { id => 'PCM' },
  "5.20.1-RC1" => { id => 'SHAY' },
  "5.20.1-RC2" => { id => 'SHAY' },
  "5.20.1" => { id => 'SHAY' },
  "5.21.4" => { id => 'SHAY' },
  "5.18.3" => { id => 'RJBS' },
  "5.18.4" => { id => 'RJBS' },
  "5.21.5" => { id => 'ABIGAIL' },
  "5.21.6" => { id => 'BINGOS' },
  "5.21.8" => { id => 'WOLFSAGE' },
  "5.20.2-RC1" => { id => 'SHAY' },
  "5.20.2" => { id => 'SHAY' },
  "5.21.10" => { id => 'SHAY' },
  "5.21.11" => { id => 'SHAY' },
  "5.22.0" => { id => 'RJBS' },
  "5.23.1" => { id => 'WOLFSAGE' },
  "5.23.2" => { id => 'WOLFSAGE' },
  "5.20.3-RC1" => { id => 'SHAY' },
  "5.20.3-RC2" => { id => 'SHAY' },
  "5.20.3" => { id => 'SHAY' },
  "5.23.3" => { id => 'PCM' },
  "5.23.4" => { id => 'SHAY' },
  "5.22.1-RC1" => { id => 'SHAY' },
  "5.22.1-RC2" => { id => 'SHAY' },
  "5.23.5" => { id => 'ABIGAIL' },
  "5.22.1-RC3" => { id => 'SHAY' },
  "5.22.1-RC4" => { id => 'SHAY' },
  "5.22.1" => { id => 'SHAY' },
  "5.23.6" => { id => 'DAGOLDEN', noxz => 1 },
  "5.23.7" => { id => 'STEVAN' },
  "5.23.9" => { id => 'ABIGAIL' },
  "5.22.2-RC1" => { id => 'SHAY' },
  "5.22.2" => { id => 'SHAY' },
  "5.24.0" => { id => 'RJBS' },
  "5.25.2" => { id => 'WOLFSAGE' },
  "5.22.3-RC1" => { id => 'SHAY' },
  "5.24.1-RC1" => { id => 'SHAY' },
  "5.25.3" => { id => 'SHAY' },
  "5.22.3-RC2" => { id => 'SHAY' },
  "5.24.1-RC2" => { id => 'SHAY' },
  "5.22.3-RC3" => { id => 'SHAY' },
  "5.24.1-RC3" => { id => 'SHAY' },
  "5.25.4" => { id => 'BINGOS' },
  "5.25.5" => { id => 'STEVAN' },
  "5.22.3-RC4" => { id => 'SHAY' },
  "5.24.1-RC4" => { id => 'SHAY' },
  "5.25.6" => { id => 'ARC' },
  "5.25.7" => { id => 'EXODIST' },
  "5.22.3-RC5" => { id => 'SHAY' },
  "5.24.1-RC5" => { id => 'SHAY', noxz => 1 },
  "5.22.3" => { id => 'SHAY' },
  "5.24.1" => { id => 'SHAY' },
  "5.25.9" => { id => 'ABIGAIL' },
  "5.25.10" => { id => 'RENEEB' },
  "5.26.0" => { id => 'XSAWYERX' },
  "5.27.1" => { id => 'EHERMAN' },
  "5.22.4-RC1" => { id => 'SHAY' },
  "5.24.2-RC1" => { id => 'SHAY' },
  "5.22.4" => { id => 'SHAY' },
  "5.24.2" => { id => 'SHAY' },
  "5.27.2" => { id => 'ARC' },
  "5.27.3" => { id => 'WOLFSAGE' },
  "5.24.3-RC1" => { id => 'SHAY' },
  "5.26.1-RC1" => { id => 'SHAY' },
  "5.27.4" => { id => 'GENEHACK' },
  "5.24.3" => { id => 'SHAY' },
  "5.26.1" => { id => 'SHAY' },
  "5.27.5" => { id => 'SHAY' },
  "5.27.6" => { id => 'ETHER' },
  "5.27.7" => { id => 'BINGOS' },
  "5.27.8" => { id => 'ABIGAIL' },
  "5.27.9" => { id => 'RENEEB' },
  "5.27.10" => { id => 'TODDR' },
  "5.24.4-RC1" => { id => 'SHAY' },
  "5.26.2-RC1" => { id => 'SHAY' },
  "5.24.4" => { id => 'SHAY' },
  "5.26.2" => { id => 'SHAY' },
  "5.27.11" => { id => 'XSAWYERX' },
  "5.28.0-RC1" => { id => 'XSAWYERX' },
  "5.28.0-RC2" => { id => 'XSAWYERX' },
  "5.28.0-RC3" => { id => 'XSAWYERX' },
  "5.28.0-RC4" => { id => 'XSAWYERX' },
  "5.28.0" => { id => 'XSAWYERX' },
  "5.29.0" => { id => 'XSAWYERX' },
  "5.29.1" => { id => 'SHAY' },
  "5.29.2" => { id => 'BINGOS' },
  "5.29.3" => { id => 'GENEHACK' },
  "5.29.4" => { id => 'ARC' },
  "5.29.5" => { id => 'ETHER' },
  "5.26.3" => { id => 'SHAY' },
  "5.28.1" => { id => 'SHAY' },
  "5.29.6" => { id => 'ABIGAIL' },
  "5.29.7" => { id => 'ABIGAIL' },
  "5.29.8" => { id => 'ATOOMIC' },
  "5.29.9" => { id => 'ZAKAME' },
  "5.28.2-RC1" => { id => 'SHAY' },
  "5.28.2" => { id => 'SHAY' },
  "5.29.10" => { id => 'XSAWYERX' },
  "5.30.0-RC1" => { id => 'XSAWYERX' },
  "5.30.0-RC2" => { id => 'XSAWYERX' },
  "5.30.0" => { id => 'XSAWYERX' },
  "5.31.0" => { id => 'XSAWYERX' },
  "5.31.1" => { id => 'ETHER' },
  "5.31.2" => { id => 'SHAY' },
  "5.31.4" => { id => 'CORION' },
  "5.31.5" => { id => 'SHAY' },
  "5.30.1-RC1" => { id => 'SHAY' },
  "5.30.1" => { id => 'SHAY' },
  "5.31.6" => { id => 'BINGOS' },
  "5.31.7" => { id => 'ATOOMIC' },
  "5.31.8" => { id => 'WOLFSAGE' },
  "5.31.9" => { id => 'RENEEB' },
  "5.30.2-RC1" => { id => 'SHAY' },
  "5.30.2" => { id => 'SHAY' },
  "5.31.10" => { id => 'XSAWYERX' },
  "5.31.11" => { id => 'XSAWYERX' },
  "5.32.0-RC0" => { id => 'XSAWYERX' },
  "5.28.3-RC1" => { id => 'XSAWYERX' },
  "5.28.3" => { id => 'XSAWYERX' },
  "5.30.3-RC1" => { id => 'XSAWYERX' },
  "5.30.3" => { id => 'XSAWYERX' },
  "5.32.0-RC1" => { id => 'XSAWYERX' },
  "5.32.0" => { id => 'XSAWYERX' },
  "5.33.0" => { id => 'XSAWYERX' },
  "5.33.1" => { id => 'ETHER' },
  "5.33.2" => { id => 'XSAWYERX' },
  "5.33.3" => { id => 'SHAY' },
  "5.33.5" => { id => 'CORION' },
  "5.32.1-RC1" => { id => 'SHAY' },
  "5.33.6" => { id => 'HYDAHY' },
  "5.32.1" => { id => 'SHAY' },
  "5.33.7" => { id => 'RENEEB' },
  "5.33.8" => { id => 'ATOOMIC' },
  "5.33.9" => { id => 'TODDR' },
  "5.34.0-RC1" => { id => 'XSAWYERX' },
  "5.34.0-RC2" => { id => 'XSAWYERX' },
  "5.34.0" => { id => 'XSAWYERX' },
  "5.35.0" => { id => 'RJBS' },
  "5.35.1" => { id => 'CORION' },
  "5.35.3" => { id => 'ETHER' },
  "5.35.4" => { id => 'WOLFSAGE' },
  "5.35.5" => { id => 'LEONT' },
  "5.35.6" => { id => 'HYDAHY' },
  "5.35.8" => { id => 'ATOOMIC' },
  "5.35.9" => { id => 'RENEEB' },
  "5.34.1-RC1" => { id => 'SHAY' },
  "5.34.1-RC2" => { id => 'SHAY' },
  "5.34.1" => { id => 'SHAY' },
  "5.35.10" => { id => 'XSAWYERX' },
  "5.35.11" => { id => 'SHAY' },
  "5.36.0-RC2" => { id => 'RJBS' },
  "5.36.0-RC3" => { id => 'RJBS' },
  "5.36.0" => { id => 'RJBS' },
  "5.37.0" => { id => 'RJBS' },
  "5.37.1" => { id => 'WOLFSAGE' },
  "5.37.2" => { id => 'ATOOMIC' },
  "5.37.4" => { id => 'ETHER' },
  "5.37.5" => { id => 'TODDR' },
  "5.37.6" => { id => 'CORION' },
  "5.37.7" => { id => 'HYDAHY' },
  "5.37.8" => { id => 'RENEEB' },
  "5.37.9" => { id => 'ETHER' },
  "5.37.10" => { id => 'YVES' },
  "5.36.1-RC1" => { id => 'SHAY' },
  "5.36.1-RC2" => { id => 'SHAY' },
  "5.36.1-RC3" => { id => 'SHAY' },
  "5.37.11" => { id => 'SHAY' },
  "5.36.1" => { id => 'SHAY' },
  "5.38.0-RC1" => { id => 'RJBS' },
  "5.38.0-RC2" => { id => 'RJBS' },
  "5.38.0" => { id => 'RJBS' },
  "5.39.1" => { id => 'SHAY' },
  };
  
  sub perl_tarballs {
    my $vers = shift;
    return unless defined $vers;
    $vers = shift if eval { $vers->isa(__PACKAGE__) };
    return unless exists $data->{ $vers };
    if ( exists $cache->{ $vers } ) {
      return { %{ $cache->{ $vers } } };
    }
    my $pumpkin = $data->{ $vers }->{id};
    my $path = join '/', substr( $pumpkin, 0, 1 ), substr( $pumpkin, 0, 2 ), $pumpkin;
    my $sep = ( $vers =~ m!^5\.0! ? '' : '-' );
    my $perl = join $sep, 'perl', $vers;
    my $onlygz = 1 if $vers =~ m!(?-xism:5.(?:00(?:4(?:_0[12345])?|5(?:_0[1234])?|3_07)|1(?:0.0(?:-RC[12])?|6.0-RC0)|6.(?:[02]|1(?:-TRIAL[123])?)|9.[12345]|7.[0123]|8.[01]))! || $data->{ $vers }->{onlygz};
    my $onlybz2 = 1 if $data->{ $vers }->{onlybz2};
    my $noxz = 1 if $data->{ $vers }->{noxz};
    my $lvers;
    {
      my $tvers = $vers;
      $tvers =~ s!\-?(TRIAL|RC)\d*!!g;
      $tvers =~ s!_!.!g;
      my @parts = split m!\.!, $tvers;
      push @parts, 0 if scalar @parts < 3;
      $lvers = sprintf("%d.%03d%03d",@parts);
    }
    my $foo = { };
    $foo->{'tar.gz'} = "$path/$perl.tar.gz" unless $onlybz2;
    $foo->{'tar.bz2'} = "$path/$perl.tar.bz2" unless $onlygz || $lvers > 5.027005;
    $foo->{'tar.xz'} = "$path/$perl.tar.xz" if $lvers > 5.021005 && !$noxz;
    delete $foo->{'tar.bz2'} if $pumpkin eq 'SHAY' && $lvers < 5.028000;
    $cache->{ $vers } = $foo;
    return { %$foo };
  }
  
  sub perl_versions {
      return sort _by_version keys %$data;
  }
  
  
  sub _by_version {
    my %v = map {
      my @v = split(qr/[-._]0*/, $_);
      $v[2] ||= 0;
      $v[3] ||= 'Z';
      ($_ => sprintf '%d.%03d%03d-%s', @v)
    } $a, $b;
    $v{$a} cmp $v{$b};
  }
  
  sub perl_pumpkins {
      my %pumps = map { ( $data->{$_}->{id} => 1 ) } keys %$data;
      return sort keys %pumps;
  }
  
  q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Perl::Releases - Mapping Perl releases on CPAN to the location of the tarballs
  
  =head1 VERSION
  
  version 5.20230720
  
  =head1 SYNOPSIS
  
    use CPAN::Perl::Releases qw[perl_tarballs];
  
    my $perl = '5.14.0';
  
    my $hashref = perl_tarballs( $perl );
  
    print "Location: ", $_, "\n" for values %{ $hashref };
  
  =head1 DESCRIPTION
  
  CPAN::Perl::Releases is a module that contains the mappings of all C<perl> releases that have been uploaded to CPAN to the
  C<authors/id/> path that the tarballs reside in.
  
  This is static data, but newer versions of this module will be made available as new releases of C<perl> are uploaded to CPAN.
  
  =head1 FUNCTIONS
  
  =over
  
  =item C<perl_tarballs>
  
  Takes one parameter, a C<perl> version to search for. Returns an hashref on success or C<undef> otherwise.
  
  The returned hashref will have a key/value for each type of tarball. A key of C<tar.gz> indicates the location
  of a gzipped tar file and C<tar.bz2> of a bzip2'd tar file. The values will be the relative path under C<authors/id/>
  on CPAN where the indicated tarball will be located.
  
    perl_tarballs( '5.14.0' );
  
    Returns a hashref like:
  
    {
      "tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2",
      "tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz"
    }
  
  Not all C<perl> releases had C<tar.bz2>, but only a C<tar.gz>.
  
  Perl tarballs may also be compressed using C<xz> and therefore have a C<tar.xz> entry.
  
  =item C<perl_versions>
  
  Returns the list of all the perl versions supported by the module in ascending order. C<TRIAL> and C<RC> will be lower
  than an actual release.
  
  =item C<perl_pumpkins>
  
  Returns a sorted list of all PAUSE IDs of Perl pumpkins.
  
  =back
  
  =head1 SEE ALSO
  
  L<http://www.cpan.org/src/5.0/>
  
  =head1 AUTHOR
  
  Chris Williams <chris@bingosnet.co.uk>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2023 by Chris Williams.
  
  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
CPAN_PERL_RELEASES

$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.48';
  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, $apply_layers) = @_;
    # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
  
    # eliminate pseudo-layers
    binmode( $fh, ":raw" );
    # strip off real layers until only :unix is left
    while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
        binmode( $fh, ":pop" );
    }
    # apply other layers
    my @to_apply = @$apply_layers;
    shift @to_apply; # eliminate initial :unix
    # _debug("# applying layers  (unix @to_apply) to @{[fileno $fh]}\n");
    binmode($fh, ":" . join(":",@to_apply));
  }
  
  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 ) {
      my $old_eval_err=$@;
      undef $@;
  
      eval "use Win32API::File qw/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
      $@=$old_eval_err;
    }
    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\n");
      close($_) 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, $orig_pid, @result);
    {
      $orig_pid = $$;
      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" );
      my $old_eval_err=$@;
      undef $@;
      eval { @result = $code->(); $inner_error = $@ };
      $exit_code = $?; # save this for later
      $outer_error = $@; # save this for later
      STDOUT->flush if $do_stdout;
      STDERR->flush if $do_stderr;
      $@ = $old_eval_err;
    }
    # 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 ( $orig_pid == $$ and ( 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.48
  
  =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 read/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 its 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 and/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.
  
  =head3 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.
  
  =head3 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).
  
  =head3 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.
  
  =head3 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.
  
  =head3 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.
  
  =head3 Forking inside a capture
  
  Forks aren't portable.  The behavior of filehandles during a fork is even
  less so.  If Capture::Tiny detects that a fork has occurred within a
  capture, it will shortcut in the child process and return empty strings for
  captures.  Other problems may occur in the child or parent, as well.
  Forking in a capture block is not recommended.
  
  =head3 Using threads
  
  Filehandles are global.  Mixing up I/O and captures in different threads
  without coordination is going to cause problems.  Besides, threads are
  officially discouraged.
  
  =head3 Dropping privileges during a capture
  
  If you drop privileges during a capture, temporary files created to
  facilitate the capture may not be cleaned up afterwards.
  
  =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 internally for C<tee>.  By default,
  Capture::Tiny will timeout with an error if such 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.  B<NOTE>, this does not timeout the code reference being
  captured -- this only prevents Capture::Tiny itself from hanging your process
  waiting for its child processes to be ready to proceed.
  
  =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 4
  
  =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 fecundf Graham Knop Peter Rabbitson
  
  =over 4
  
  =item *
  
  Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
  
  =item *
  
  David E. Wheeler <david@justatheory.com>
  
  =item *
  
  fecundf <not.com+github@gmail.com>
  
  =item *
  
  Graham Knop <haarg@haarg.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =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{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
  package JSON::PP;
  
  # JSON-2.0
  
  use 5.008;
  use strict;
  
  use Exporter ();
  BEGIN { our @ISA = ('Exporter') }
  
  use overload ();
  use JSON::PP::Boolean;
  
  use Carp ();
  use Scalar::Util qw(blessed reftype refaddr);
  #use Devel::Peek;
  
  our $VERSION = '4.16';
  
  our @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 P_ALLOW_TAGS           => 19;
  
  use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
  use constant CORE_BOOL => defined &builtin::is_bool;
  
  my $invalid_char_re;
  
  BEGIN {
      $invalid_char_re = "[";
      for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
          $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
      }
  
      $invalid_char_re = qr/$invalid_char_re]/;
  }
  
  BEGIN {
      if (USE_B) {
          require B;
      }
  }
  
  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
              allow_tags
      );
      my @pp_bit_properties = qw(
              allow_singlequote allow_bignum loose
              allow_barekey escape_slash as_nonblessed
      );
  
      for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
          my $property_id = 'P_' . uc($name);
  
          eval qq/
              sub $name {
                  my \$enable = defined \$_[1] ? \$_[1] : 1;
  
                  if (\$enable) {
                      \$_[0]->{PROPS}->[$property_id] = 1;
                  }
                  else {
                      \$_[0]->{PROPS}->[$property_id] = 0;
                  }
  
                  \$_[0];
              }
  
              sub get_$name {
                  \$_[0]->{PROPS}->[$property_id] ? 1 : '';
              }
          /;
      }
  
  }
  
  
  
  # Functions
  
  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_length => 3,
      };
  
      $self->{PROPS}[P_ALLOW_NONREF] = 1;
  
      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)->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 boolean_values {
      my $self = shift;
      if (@_) {
          my ($false, $true) = @_;
          $self->{false} = $false;
          $self->{true} = $true;
          if (CORE_BOOL) {
              BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) }
              if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) {
                  $self->{core_bools} = !!1;
              }
              else {
                  delete $self->{core_bools};
              }
          }
      } else {
          delete $self->{false};
          delete $self->{true};
          delete $self->{core_bools};
      }
      return $self;
  }
  
  sub core_bools {
      my $self = shift;
      my $core_bools = defined $_[0] ? $_[0] : 1;
      if ($core_bools) {
          $self->{true} = !!1;
          $self->{false} = !!0;
          $self->{core_bools} = !!1;
      }
      else {
          $self->{true} = $JSON::PP::true;
          $self->{false} = $JSON::PP::false;
          $self->{core_bools} = !!0;
      }
      return $self;
  }
  
  sub get_core_bools {
      my $self = shift;
      return !!$self->{core_bools};
  }
  
  sub unblessed_bool {
      my $self = shift;
      return $self->core_bools(@_);
  }
  
  sub get_unblessed_bool {
      my $self = shift;
      return $self->get_core_bools(@_);
  }
  
  sub get_boolean_values {
      my $self = shift;
      if (exists $self->{true} and exists $self->{false}) {
          return @$self{qw/false true/};
      }
      return;
  }
  
  sub filter_json_object {
      if (defined $_[1] and ref $_[1] eq 'CODE') {
          $_[0]->{cb_object} = $_[1];
      } else {
          delete $_[0]->{cb_object};
      }
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
      $_[0];
  }
  
  sub filter_json_single_key_object {
      if (@_ == 1 or @_ > 3) {
          Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
      }
      if (defined $_[2] and ref $_[2] eq 'CODE') {
          $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
      } else {
          delete $_[0]->{cb_sk_object}->{$_[1]};
          delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
      }
      $_[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() instead.");
      $_[0]->allow_bignum;
  }
  
  ###############################
  
  ###
  ### 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 $allow_tags;
  
      my $depth;
      my $indent_count;
      my $keysort;
  
  
      sub PP_encode_json {
          my $self = shift;
          my $obj  = shift;
  
          $indent_count = 0;
          $depth        = 0;
  
          my $props = $self->{PROPS};
  
          ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
              $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags)
           = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
                      P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS];
  
          ($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 !$props->[ P_ALLOW_NONREF ]);
  
          my $str  = $self->object_to_json($obj);
  
          $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
  
          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 ( $allow_tags and $obj->can('FREEZE') ) {
                      my $obj_class = ref $obj || $obj;
                      $obj = bless $obj, $obj_class;
                      my @results = $obj->FREEZE('JSON');
                      if ( @results and ref $results[0] ) {
                          if ( refaddr( $obj ) eq refaddr( $results[0] ) ) {
                              encode_error( sprintf(
                                  "%s::FREEZE method returned same object as was passed instead of a new one",
                                  ref $obj
                              ) );
                          }
                      }
                      return '("'.$obj_class.'")['.join(',', @results).']';
                  }
  
                  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) );
  
                  if ($allow_blessed) {
                      return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
                      return 'null';
                  }
                  encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj)
                  );
              }
              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 ) ) {
              push @res, $self->string_to_json( $k )
                            .  $del
                            . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) );
          }
  
          --$depth;
          $self->_down_indent() if ($indent);
  
          return '{}' unless @res;
          return '{' . $pre . 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, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
          }
  
          --$depth;
          $self->_down_indent() if ($indent);
  
          return '[]' unless @res;
          return '[' . $pre . join( ",$pre", @res ) . $post . ']';
      }
  
      sub _looks_like_number {
          my $value = shift;
          if (USE_B) {
              my $b_obj = B::svref_2object(\$value);
              my $flags = $b_obj->FLAGS;
              return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
              return;
          } else {
              no warnings 'numeric';
              # if the utf8 flag is on, it almost certainly started as a string
              return if utf8::is_utf8($value);
              # detect numbers
              # string & "" -> ""
              # number & "" -> 0 (with warning)
              # nan and inf can detect as numbers, so check with * 0
              return unless length((my $dummy = "") & $value);
              return unless 0 + $value eq $value;
              return 1 if $value * 0 == 0;
              return -1; # inf/nan
          }
      }
  
      sub value_to_json {
          my ($self, $value) = @_;
  
          return 'null' if(!defined $value);
  
          my $type = ref($value);
  
          if (!$type) {
              BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
              if (CORE_BOOL && builtin::is_bool($value)) {
                  return $value ? 'true' : 'false';
              }
              elsif (_looks_like_number($value)) {
                  return $value;
              }
              return $self->string_to_json($value);
          }
          elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
              return $$value == 1 ? 'true' : 'false';
          }
          else {
              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");
                  }
              }
  
          }
      }
  
  
      my %esc = (
          "\n" => '\n',
          "\r" => '\r',
          "\t" => '\t',
          "\f" => '\f',
          "\b" => '\b',
          "\"" => '\"',
          "\\" => '\\\\',
          "\'" => '\\\'',
      );
  
  
      sub string_to_json {
          my ($self, $arg) = @_;
  
          $arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g;
          $arg =~ s/\//\\\//g if ($escape_slash);
  
          # On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f]
          $arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg;
  
          if ($ascii) {
              $arg = _encode_ascii($arg);
          }
  
          if ($latin1) {
              $arg = _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 {
              chr($_) =~ /[[:ascii:]]/ ?
                  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    => "\b",
          t    => "\t",
          n    => "\n",
          f    => "\f",
          r    => "\r",
          '\\' => '\\',
          '"'  => '"',
          '/'  => '/',
      );
  
      my $text; # json data
      my $at;   # offset
      my $ch;   # first character
      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 number of objects and arrays
      my $max_size;
      my $relaxed;
      my $cb_object;
      my $cb_sk_object;
  
      my $F_HOOK;
  
      my $allow_bignum;   # using Math::BigInt/BigFloat
      my $singlequote;    # loosely quoting
      my $loose;          # 
      my $allow_barekey;  # bareKey
      my $allow_tags;
  
      my $alt_true;
      my $alt_false;
  
      sub _detect_utf_encoding {
          my $text = shift;
          my @octets = unpack('C4', $text);
          return 'unknown' unless defined $octets[3];
          return ( $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';
      }
  
      sub PP_decode_json {
          my ($self, $want_offset);
  
          ($self, $text, $want_offset) = @_;
  
          ($at, $ch, $depth) = (0, '', 0);
  
          if ( !defined $text or ref $text ) {
              decode_error("malformed JSON string, neither array, object, number, string or atom");
          }
  
          my $props = $self->{PROPS};
  
          ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags)
              = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS];
  
          ($alt_true, $alt_false) = @$self{qw/true false/};
  
          if ( $utf8 ) {
              $encoding = _detect_utf_encoding($text);
              if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
                  require Encode;
                  Encode::from_to($text, $encoding, 'utf-8');
              } else {
                  utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
              }
          }
          else {
              utf8::encode( $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);
          }
  
          white(); # remove head white space
  
          decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure?
  
          my $result = value();
  
          if ( !$props->[ 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
  
          return ( $result, $consumed ) if $want_offset; # all right if decode_prefix
  
          decode_error("garbage after JSON object") if defined $ch;
  
          $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 tag()    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 $utf16;
          my $is_utf8;
  
          ($is_valid_utf8, $utf8_len) = ('', 0);
  
          my $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 .= _decode_surrogates($utf16, $u) || next;
                              $utf16 = undef;
                          }
                          else {
                              if (defined $utf16) {
                                  decode_error("surrogate pair expected");
                              }
  
                              my $hex = hex( $u );
                              if ( chr $u =~ /[[:^ascii:]]/ ) {
                                  $is_utf8 = 1;
                                  $s .= _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 ( $ch =~ /[[:^ascii:]]/ ) {
                          unless( $ch = is_valid_utf8($ch) ) {
                              $at -= 1;
                              decode_error("malformed UTF-8 character in JSON string");
                          }
                          else {
                              $at += $utf8_len - 1;
                          }
  
                          $is_utf8 = 1;
                      }
  
                      if (!$loose) {
                          if ($ch =~ $invalid_char_re)  { # '/' ok
                              if (!$relaxed or $ch ne "\t") {
                                  $at--;
                                  decode_error(sprintf "invalid character 0x%X"
                                     . " encountered while parsing JSON string",
                                     ord $ch);
                              }
                          }
                      }
  
                      $s .= $ch;
                  }
              }
          }
  
          decode_error("unexpected end of string while parsing JSON string");
      }
  
  
      sub white {
          while( defined $ch  ){
              if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
                  next_chr();
              }
              elsif($relaxed and $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;
                  }
  
              }
          }
  
          $at-- if defined $ch and $ch ne '';
          decode_error(", or ] expected while parsing array");
      }
  
      sub tag {
          decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags;
  
          next_chr();
          white();
  
          my $tag = value();
          return unless defined $tag;
          decode_error('malformed JSON string, (tag) must be a string') if ref $tag;
  
          white();
  
          if (!defined $ch or $ch ne ')') {
              decode_error(') expected after tag');
          }
  
          next_chr();
          white();
  
          my $val = value();
          return unless defined $val;
          decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY';
  
          if (!eval { $tag->can('THAW') }) {
               decode_error('cannot decode perl-object (package does not exist)') if $@;
               decode_error('cannot decode perl-object (package does not have a THAW method)');
          }
          $tag->THAW('JSON', @$val);
      }
  
      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-- if defined $ch and $ch ne '';
          decode_error(", or } expected while parsing object/hash");
      }
  
  
      sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
          my $key;
          while($ch =~ /[\$\w[:^ascii:]]/){
              $key .= $ch;
              next_chr();
          }
          return $key;
      }
  
  
      sub word {
          my $word =  substr($text,$at-1,4);
  
          if($word eq 'true'){
              $at += 3;
              next_chr;
              return defined $alt_true ? $alt_true : $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 defined $alt_false ? $alt_false : $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;
          my $is_dec;
          my $is_exp;
  
          if($ch eq '-'){
              $n = '-';
              next_chr;
              if (!defined $ch or $ch !~ /\d/) {
                  decode_error("malformed number (no digits after initial minus)");
              }
          }
  
          # According to RFC4627, hex or oct digits are invalid.
          if($ch eq '0'){
              my $peek = substr($text,$at,1);
              if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
                  decode_error("malformed number (leading zero must not be followed by another digit)");
              }
              $n .= $ch;
              next_chr;
          }
  
          while(defined $ch and $ch =~ /\d/){
              $n .= $ch;
              next_chr;
          }
  
          if(defined $ch and $ch eq '.'){
              $n .= '.';
              $is_dec = 1;
  
              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;
              $is_exp = 1;
              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 ($is_dec or $is_exp) {
              if ($allow_bignum) {
                  require Math::BigFloat;
                  return Math::BigFloat->new($v);
              }
          } else {
              if (length $v > $max_intsize) {
                  if ($allow_bignum) { # from Adam Sussman
                      require Math::BigInt;
                      return Math::BigInt->new($v);
                  }
                  else {
                      return "$v";
                  }
              }
          }
  
          return $is_dec ? $v/1.0 : 0+$v;
      }
  
      # Compute how many bytes are in the longest legal official Unicode
      # character
      my $max_unicode_length = do {
        no warnings 'utf8';
        chr 0x10FFFF;
      };
      utf8::encode($max_unicode_length);
      $max_unicode_length = length $max_unicode_length;
  
      sub is_valid_utf8 {
  
          # Returns undef (setting $utf8_len to 0) unless the next bytes in $text
          # comprise a well-formed UTF-8 encoded character, in which case,
          # return those bytes, setting $utf8_len to their count.
  
          my $start_point = substr($text, $at - 1);
  
          # Look no further than the maximum number of bytes in a single
          # character
          my $limit = $max_unicode_length;
          $limit = length($start_point) if $limit > length($start_point);
  
          # Find the number of bytes comprising the first character in $text
          # (without having to know the details of its internal representation).
          # This loop will iterate just once on well-formed input.
          while ($limit > 0) {    # Until we succeed or exhaust the input
              my $copy = substr($start_point, 0, $limit);
  
              # decode() will return true if all bytes are valid; false
              # if any aren't.
              if (utf8::decode($copy)) {
  
                  # Is valid: get the first character, convert back to bytes,
                  # and return those bytes.
                  $copy = substr($copy, 0, 1);
                  utf8::encode($copy);
                  $utf8_len = length $copy;
                  return substr($start_point, 0, $utf8_len);
              }
  
              # If it didn't work, it could be that there is a full legal character
              # followed by a partial or malformed one.  Narrow the window and
              # try again.
              $limit--;
          }
  
          # Failed to find a legal UTF-8 character.
          $utf8_len = 0;
          return;
      }
  
  
      sub decode_error {
          my $error  = shift;
          my $no_rep = shift;
          my $str    = defined $text ? substr($text, $at) : '';
          my $mess   = '';
          my $type   = 'U*';
  
          for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
              my $chr_c = chr($c);
              $mess .=  $chr_c eq '\\' ? '\\\\'
                      : $chr_c =~ /[[:print:]]/ ? $chr_c
                      : $chr_c eq '\a' ? '\a'
                      : $chr_c eq '\t' ? '\t'
                      : $chr_c eq '\n' ? '\n'
                      : $chr_c eq '\r' ? '\r'
                      : $chr_c eq '\f' ? '\f'
                      : 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 == 0) {
                  return $o;
              }
              elsif (@val == 1) {
                  return $val[0];
              }
              else {
                  Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar");
              }
          }
  
          my @val = $cb_object->($o) if ($cb_object);
          if (@val == 0) {
              return $o;
          }
          elsif (@val == 1) {
              return $val[0];
          }
          else {
              Carp::croak("filter_json_object callbacks must not return more than one scalar");
          }
      }
  
  
      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;
  }
  
  sub incr_parse {
      local $Carp::CarpLevel = 1;
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
  }
  
  
  sub incr_skip {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
  }
  
  
  sub incr_reset {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
  }
  
  sub incr_text : lvalue {
      $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  
      if ( $_[0]->{_incr_parser}->{incr_pos} ) {
          Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
      }
      $_[0]->{_incr_parser}->{incr_text};
  }
  
  
  ###############################
  # Utilities
  #
  
  # shamelessly 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 {
    if (blessed $_[0]) {
      return (
        $_[0]->isa("JSON::PP::Boolean")
        or $_[0]->isa("Types::Serialiser::BooleanBase")
        or $_[0]->isa("JSON::XS::Boolean")
      );
    }
    elsif (CORE_BOOL) {
      BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
      return builtin::is_bool($_[0]);
    }
    return !!0;
  }
  
  sub true  { $JSON::PP::true  }
  sub false { $JSON::PP::false }
  sub null  { undef; }
  
  ###############################
  
  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;
  use constant INCR_M_TFN  => 6;
  use constant INCR_M_NUM  => 7;
  
  our $VERSION = '1.01';
  
  sub new {
      my ( $class ) = @_;
  
      bless {
          incr_nest    => 0,
          incr_text    => undef,
          incr_pos     => 0,
          incr_mode    => 0,
      }, $class;
  }
  
  
  sub incr_parse {
      my ( $self, $coder, $text ) = @_;
  
      $self->{incr_text} = '' unless ( defined $self->{incr_text} );
  
      if ( defined $text ) {
          $self->{incr_text} .= $text;
      }
  
      if ( defined wantarray ) {
          my $max_size = $coder->get_max_size;
          my $p = $self->{incr_pos};
          my @ret;
          {
              do {
                  unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
                      $self->_incr_parse( $coder );
  
                      if ( $max_size and $self->{incr_pos} > $max_size ) {
                          Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
                      }
                      unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
                          # as an optimisation, do not accumulate white space in the incr buffer
                          if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
                              $self->{incr_pos} = 0;
                              $self->{incr_text} = '';
                          }
                          last;
                      }
                  }
  
                  unless ( $coder->get_utf8 ) {
                      utf8::decode( $self->{incr_text} );
                  }
  
                  my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
                  push @ret, $obj;
                  use bytes;
                  $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
                  $self->{incr_pos} = 0;
                  $self->{incr_nest} = 0;
                  $self->{incr_mode} = 0;
                  last unless wantarray;
              } while ( wantarray );
          }
  
          if ( wantarray ) {
              return @ret;
          }
          else { # in scalar context
              return defined $ret[0] ? $ret[0] : undef;
          }
      }
  }
  
  
  sub _incr_parse {
      my ($self, $coder) = @_;
      my $text = $self->{incr_text};
      my $len = length $text;
      my $p = $self->{incr_pos};
  
  INCR_PARSE:
      while ( $len > $p ) {
          my $s = substr( $text, $p, 1 );
          last INCR_PARSE unless defined $s;
          my $mode = $self->{incr_mode};
  
          if ( $mode == INCR_M_WS ) {
              while ( $len > $p ) {
                  $s = substr( $text, $p, 1 );
                  last INCR_PARSE unless defined $s;
                  if ( ord($s) > ord " " ) {
                      if ( $s eq '#' ) {
                          $self->{incr_mode} = INCR_M_C0;
                          redo INCR_PARSE;
                      } else {
                          $self->{incr_mode} = INCR_M_JSON;
                          redo INCR_PARSE;
                      }
                  }
                  $p++;
              }
          } elsif ( $mode == INCR_M_BS ) {
              $p++;
              $self->{incr_mode} = INCR_M_STR;
              redo INCR_PARSE;
          } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
              while ( $len > $p ) {
                  $s = substr( $text, $p, 1 );
                  last INCR_PARSE unless defined $s;
                  if ( $s eq "\n" ) {
                      $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
                      last;
                  }
                  $p++;
              }
              next;
          } elsif ( $mode == INCR_M_TFN ) {
              last INCR_PARSE if $p >= $len && $self->{incr_nest};
              while ( $len > $p ) {
                  $s = substr( $text, $p++, 1 );
                  next if defined $s and $s =~ /[rueals]/;
                  last;
              }
              $p--;
              $self->{incr_mode} = INCR_M_JSON;
  
              last INCR_PARSE unless $self->{incr_nest};
              redo INCR_PARSE;
          } elsif ( $mode == INCR_M_NUM ) {
              last INCR_PARSE if $p >= $len && $self->{incr_nest};
              while ( $len > $p ) {
                  $s = substr( $text, $p++, 1 );
                  next if defined $s and $s =~ /[0-9eE.+\-]/;
                  last;
              }
              $p--;
              $self->{incr_mode} = INCR_M_JSON;
  
              last INCR_PARSE unless $self->{incr_nest};
              redo INCR_PARSE;
          } elsif ( $mode == INCR_M_STR ) {
              while ( $len > $p ) {
                  $s = substr( $text, $p, 1 );
                  last INCR_PARSE unless defined $s;
                  if ( $s eq '"' ) {
                      $p++;
                      $self->{incr_mode} = INCR_M_JSON;
  
                      last INCR_PARSE unless $self->{incr_nest};
                      redo INCR_PARSE;
                  }
                  elsif ( $s eq '\\' ) {
                      $p++;
                      if ( !defined substr($text, $p, 1) ) {
                          $self->{incr_mode} = INCR_M_BS;
                          last INCR_PARSE;
                      }
                  }
                  $p++;
              }
          } elsif ( $mode == INCR_M_JSON ) {
              while ( $len > $p ) {
                  $s = substr( $text, $p++, 1 );
                  if ( $s eq "\x00" ) {
                      $p--;
                      last INCR_PARSE;
                  } elsif ( $s =~ /^[\t\n\r ]$/) {
                      if ( !$self->{incr_nest} ) {
                          $p--; # do not eat the whitespace, let the next round do it
                          last INCR_PARSE;
                      }
                      next;
                  } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) {
                      $self->{incr_mode} = INCR_M_TFN;
                      redo INCR_PARSE;
                  } elsif ( $s =~ /^[0-9\-]$/ ) {
                      $self->{incr_mode} = INCR_M_NUM;
                      redo INCR_PARSE;
                  } elsif ( $s eq '"' ) {
                      $self->{incr_mode} = INCR_M_STR;
                      redo INCR_PARSE;
                  } elsif ( $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?)');
                      }
                      next;
                  } elsif ( $s eq ']' or $s eq '}' ) {
                      if ( --$self->{incr_nest} <= 0 ) {
                          last INCR_PARSE;
                      }
                  } elsif ( $s eq '#' ) {
                      $self->{incr_mode} = INCR_M_C1;
                      redo INCR_PARSE;
                  }
              }
          }
      }
  
      $self->{incr_pos} = $p;
      $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
  }
  
  
  sub incr_text {
      if ( $_[0]->{incr_pos} ) {
          Carp::croak("incr_text cannot 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_pos} );
      $self->{incr_pos}     = 0;
      $self->{incr_mode}    = 0;
      $self->{incr_nest}    = 0;
  }
  
  
  sub incr_reset {
      my $self = shift;
      $self->{incr_text}    = undef;
      $self->{incr_pos}     = 0;
      $self->{incr_mode}    = 0;
      $self->{incr_nest}    = 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
  
   $json = JSON::PP->new->ascii->pretty->allow_nonref;
   
   $pretty_printed_json_text = $json->encode( $perl_scalar );
   $perl_scalar = $json->decode( $json_text );
   
   # 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 DESCRIPTION
  
  JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much
  faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as
  a fallback module when you use L<JSON> module without having
  installed JSON::XS.
  
  Because of this fallback feature of JSON.pm, JSON::PP tries not to
  be more JavaScript-friendly than JSON::XS (i.e. not to escape extra
  characters such as U+2028 and U+2029, etc),
  in order for you not to lose such JavaScript-friendliness silently
  when you use JSON.pm and install JSON::XS for speed or by accident.
  If you need JavaScript-friendly RFC7159-compliant pure perl module,
  try L<JSON::Tiny>, which is derived from L<Mojolicious> web
  framework and is also smaller and faster than JSON::PP.
  
  JSON::PP has been in the Perl core since Perl 5.14, mainly for
  CPAN toolchain modules to parse META.json.
  
  =head1 FUNCTIONAL INTERFACE
  
  This section is taken from JSON::XS almost verbatim. C<encode_json>
  and C<decode_json> are exported by default.
  
  =head2 encode_json
  
      $json_text = encode_json $perl_scalar
  
  Converts the given Perl data structure to a UTF-8 encoded, binary string
  (that is, the string contains octets only). Croaks on error.
  
  This function call is functionally identical to:
  
      $json_text = JSON::PP->new->utf8->encode($perl_scalar)
  
  Except being faster.
  
  =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. Croaks on error.
  
  This function call is functionally identical to:
  
      $perl_scalar = JSON::PP->new->utf8->decode($json_text)
  
  Except being faster.
  
  =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.
  
  On perl 5.36 and above, will also return true when given one of perl's
  standard boolean values, such as the result of a comparison.
  
  See L<MAPPING>, below, for more information on how JSON values are mapped to
  Perl.
  
  =head1 OBJECT-ORIENTED INTERFACE
  
  This section is also taken from JSON::XS.
  
  The object oriented interface lets you configure your own encoding or
  decoding style, within the limits of supported formats.
  
  =head2 new
  
      $json = JSON::PP->new
  
  Creates a new JSON::PP object that can be used to de/encode JSON
  strings. All boolean flags described below are by default I<disabled>
  (with the exception of C<allow_nonref>, which defaults to I<enabled> since
  version C<4.0>).
  
  The mutators for flags all return the JSON::PP 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 C<$enable> is true (or missing), then the C<encode> method will not
  generate characters outside the code range C<0..127> (which is ASCII). Any
  Unicode characters outside that range will be escaped using either a
  single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
  as per RFC4627. The resulting encoded JSON text can be treated as a native
  Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
  or any other superset of ASCII.
  
  If C<$enable> is false, then the C<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.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
  
  The main use for this flag is to produce JSON texts that can be
  transmitted over a 7-bit channel, as the encoded JSON texts will not
  contain any 8 bit characters.
  
    JSON::PP->new->ascii(1)->encode([chr 0x10401])
    => ["\ud801\udc01"]
  
  =head2 latin1
  
      $json = $json->latin1([$enable])
      
      $enabled = $json->get_latin1
  
  If C<$enable> is true (or missing), then the C<encode> method will encode
  the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
  outside the code range C<0..255>. The resulting string can be treated as a
  latin1-encoded JSON text or a native Unicode string. The C<decode> method
  will not be affected in any way by this flag, as C<decode> by default
  expects Unicode, which is a strict superset of latin1.
  
  If C<$enable> is false, then the C<encode> method will not escape Unicode
  characters unless required by the JSON syntax or other flags.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
  
  The main use for this flag is efficiently encoding binary data as JSON
  text, as most octets will not be escaped, resulting in a smaller encoded
  size. The disadvantage is that the resulting JSON text is encoded
  in latin1 (and must correctly be treated as such when storing and
  transferring), a rare encoding for JSON. It is therefore most useful when
  you want to store data structures known to contain binary data efficiently
  in files or databases, not when talking to other JSON encoders/decoders.
  
    JSON::PP->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  =head2 utf8
  
      $json = $json->utf8([$enable])
      
      $enabled = $json->get_utf8
  
  If C<$enable> is true (or missing), then the C<encode> method will encode
  the JSON result into UTF-8, as required by many protocols, while the
  C<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 C<0..255>, they are thus useful for bytewise/binary I/O. In future
  versions, enabling this option might enable autodetection of the UTF-16
  and UTF-32 encoding families, as described in RFC4627.
  
  If C<$enable> is false, then the C<encode> method will return the JSON
  string as a (non-encoded) Unicode string, while C<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.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
  
  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> (and in the future possibly more) flags in one call to
  generate the most readable (or most compact) form possible.
  
  =head2 indent
  
      $json = $json->indent([$enable])
      
      $enabled = $json->get_indent
  
  If C<$enable> is true (or missing), then the C<encode> method will use a multiline
  format as output, putting every array member or object/hash key-value pair
  into its own line, indenting them properly.
  
  If C<$enable> is false, no newlines or indenting will be produced, and the
  resulting JSON text is guaranteed not to contain any C<newlines>.
  
  This setting has no effect when decoding JSON texts.
  
  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. You will also
  most likely combine this setting with C<space_after>.
  
  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...
    ]
  
  =item * C-style multiple-line '/* */'-comments (JSON::PP only)
  
  Whenever JSON allows whitespace, C-style multiple-line comments are additionally
  allowed. Everything between C</*> and C<*/> is a comment, after which
  more white-space and comments are allowed.
  
    [
       1, /* this comment not allowed in JSON */
          /* neither this one... */
    ]
  
  =item * C++-style one-line '//'-comments (JSON::PP only)
  
  Whenever JSON allows whitespace, C++-style one-line 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...
    ]
  
  =item * literal ASCII TAB characters in strings
  
  Literal ASCII TAB characters are now allowed in strings (and treated as
  C<\t>).
  
    [
       "Hello\tWorld",
       "Hello<TAB>World", # literal <TAB> would not normally be allowed
    ]
  
  =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, and can change even within the same run from 5.18
  onwards).
  
  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.
  
  This setting has currently no effect on tied hashes.
  
  =head2 allow_nonref
  
      $json = $json->allow_nonref([$enable])
      
      $enabled = $json->get_allow_nonref
  
  Unlike other boolean options, this opotion is enabled by default beginning
  with version C<4.0>.
  
  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.
  
  Example, encode a Perl scalar as JSON value without enabled C<allow_nonref>,
  resulting in an error:
  
     JSON::PP->new->allow_nonref(0)->encode ("Hello, World!")
     => hash- or arrayref expected...
  
  =head2 allow_unknown
  
      $json = $json->allow_unknown([$enable])
      
      $enabled = $json->get_allow_unknown
  
  If C<$enable> is true (or missing), then C<encode> will I<not> throw an
  exception when it encounters values it cannot represent in JSON (for
  example, filehandles) but instead will encode a JSON C<null> value. Note
  that blessed objects are not included here and are handled separately by
  c<allow_blessed>.
  
  If C<$enable> is false (the default), then C<encode> will throw an
  exception when it encounters anything it cannot encode as JSON.
  
  This option does not affect C<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
  
  See L<OBJECT SERIALISATION> for details.
  
  If C<$enable> is true (or missing), then the C<encode> method will not
  barf when it encounters a blessed reference that it cannot convert
  otherwise. Instead, a JSON C<null> value is encoded instead of the object.
  
  If C<$enable> is false (the default), then C<encode> will throw an
  exception when it encounters a blessed object that it cannot convert
  otherwise.
  
  This setting has no effect on C<decode>.
  
  =head2 convert_blessed
  
      $json = $json->convert_blessed([$enable])
      
      $enabled = $json->get_convert_blessed
  
  See L<OBJECT SERIALISATION> for details.
  
  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.
  
  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 any C<to_json>
  function or method.
  
  If C<$enable> is false (the default), then C<encode> will not consider
  this type of conversion.
  
  This setting has no effect on C<decode>.
  
  =head2 allow_tags
  
      $json = $json->allow_tags([$enable])
  
      $enabled = $json->get_allow_tags
  
  See L<OBJECT SERIALISATION> for details.
  
  If C<$enable> is true (or missing), then C<encode>, upon encountering a
  blessed object, will check for the availability of the C<FREEZE> method on
  the object's class. If found, it will be used to serialise the object into
  a nonstandard tagged JSON value (that JSON decoders cannot decode).
  
  It also causes C<decode> to parse such tagged JSON values and deserialise
  them via a call to the C<THAW> method.
  
  If C<$enable> is false (the default), then C<encode> will not consider
  this type of conversion, and tagged JSON values will cause a parse error
  in C<decode>, as if tags were not part of the grammar.
  
  =head2 boolean_values
  
      $json->boolean_values([$false, $true])
  
      ($false,  $true) = $json->get_boolean_values
  
  By default, JSON booleans will be decoded as overloaded
  C<$JSON::PP::false> and C<$JSON::PP::true> objects.
  
  With this method you can specify your own boolean values for decoding -
  on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON
  C<true> will be decoded as C<$true> ("copy" here is the same thing as
  assigning a value to another variable, i.e. C<$copy = $false>).
  
  This is useful when you want to pass a decoded data structure directly
  to other serialisers like YAML, Data::MessagePack and so on.
  
  Note that this works only when you C<decode>. You can set incompatible
  boolean objects (like L<boolean>), but when you C<encode> a data structure
  with such boolean objects, you still need to enable C<convert_blessed>
  (and add a C<TO_JSON> method if necessary).
  
  Calling this method without any arguments will reset the booleans
  to their default values.
  
  C<get_boolean_values> will return both C<$false> and C<$true> values, or
  the empty list when they are set to the default.
  
  =head2 core_bools
  
      $json->core_bools([$enable]);
  
  If C<$enable> is true (or missing), then C<decode>, will produce standard
  perl boolean values. Equivalent to calling:
  
      $json->boolean_values(!!1, !!0)
  
  C<get_core_bools> will return true if this has been set. On perl 5.36, it will
  also return true if the boolean values have been set to perl's core booleans
  using the C<boolean_values> method.
  
  The methods C<unblessed_bool> and C<get_unblessed_bool> are provided as aliases
  for compatibility with L<Cpanel::JSON::XS>.
  
  =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 is a reference to
  the newly-created hash. If the code references returns a single scalar
  (which need not be a reference), this value (or rather a copy of it) 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('[{}]');
     # returns 5
     $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
  
  If C<$enable> is true (or missing), the string returned by C<encode> will
  be shrunk (i.e. downgraded if possible).
  
  The actual definition of what shrink does might change in future versions,
  but it will always try to save space at the expense of time.
  
  If C<$enable> is false, then JSON::PP does nothing.
  
  =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.
  
  Setting the maximum depth to one disallows any nesting, so that ensures
  that the object is only a single hash/object or array.
  
  If no argument is given, the highest possible setting will be used, which
  is rarely useful.
  
  See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
  
  =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/SECURITY CONSIDERATIONS> for more info on why this is useful.
  
  =head2 encode
  
      $json_text = $json->encode($perl_scalar)
  
  Converts the given Perl value or data structure to its JSON
  representation. Croaks on error.
  
  =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.
  
  =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.
  
  This is useful if your JSON texts are not delimited by an outer protocol
  and you need to know where the JSON text ends.
  
     JSON::PP->new->decode_prefix ("[1] the tail")
     => ([1], 3)
  
  =head1 FLAGS FOR JSON::PP ONLY
  
  The following flags and properties are for JSON::PP only. If you use
  any of these, you can't make your application run faster by replacing
  JSON::PP with JSON::XS. If you need these and also speed boost,
  you might want to try L<Cpanel::JSON::XS>, a fork of JSON::XS by
  Reini Urban, which supports some of these (with a different set of
  incompatibilities). Most of these historical flags are only kept
  for backward compatibility, and should not be used in a new application.
  
  =head2 allow_singlequote
  
      $json = $json->allow_singlequote([$enable])
      $enabled = $json->get_allow_singlequote
  
  If C<$enable> is true (or missing), then C<decode> will accept
  invalid JSON texts that contain strings that begin and end with
  single quotation marks. C<encode> will not be affected in any way.
  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.
  
      $json->allow_singlequote->decode(qq|{"foo":'bar'}|);
      $json->allow_singlequote->decode(qq|{'foo':"bar"}|);
      $json->allow_singlequote->decode(qq|{'foo':'bar'}|);
  
  =head2 allow_barekey
  
      $json = $json->allow_barekey([$enable])
      $enabled = $json->get_allow_barekey
  
  If C<$enable> is true (or missing), then C<decode> will accept
  invalid JSON texts that contain JSON objects whose names don't
  begin and end with quotation marks. C<encode> will not be affected
  in any way. 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.
  
      $json->allow_barekey->decode(qq|{foo:"bar"}|);
  
  =head2 allow_bignum
  
      $json = $json->allow_bignum([$enable])
      $enabled = $json->get_allow_bignum
  
  If C<$enable> is true (or missing), then C<decode> will convert
  big integers Perl cannot handle as integer into L<Math::BigInt>
  objects and convert floating numbers into L<Math::BigFloat>
  objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat>
  objects into JSON numbers.
  
     $json->allow_nonref->allow_bignum;
     $bigfloat = $json->decode('2.000000000000000000000000001');
     print $json->encode($bigfloat);
     # => 2.000000000000000000000000001
  
  See also L<MAPPING>.
  
  =head2 loose
  
      $json = $json->loose([$enable])
      $enabled = $json->get_loose
  
  If C<$enable> is true (or missing), then C<decode> will accept
  invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c]
  characters. C<encode> will not be affected in any way.
  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.
  
      $json->loose->decode(qq|["abc
                                     def"]|);
  
  =head2 escape_slash
  
      $json = $json->escape_slash([$enable])
      $enabled = $json->get_escape_slash
  
  If C<$enable> is true (or missing), then C<encode> will explicitly
  escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of
  XSS (cross site scripting) that may be caused by C<< </script> >>
  in a JSON text, with the cost of bloating the size of JSON texts.
  
  This option may be useful when you embed JSON in HTML, but embedding
  arbitrary JSON in HTML (by some HTML template toolkit or by string
  interpolation) is risky in general. You must escape necessary
  characters in correct order, depending on the context.
  
  C<decode> will not be affected in any way.
  
  =head2 indent_length
  
      $json = $json->indent_length($number_of_spaces)
      $length = $json->get_indent_length
  
  This option is only useful when you also enable C<indent> or C<pretty>.
  
  JSON::XS indents with three spaces when you C<encode> (if requested
  by C<indent> or C<pretty>), and the number cannot be changed.
  JSON::PP allows you to change/get the number of indent spaces with these
  mutator/accessor. The default number of spaces is three (the same as
  JSON::XS), and the acceptable range is from C<0> (no indentation;
  it'd be better to disable indentation by C<indent(0)>) to C<15>.
  
  =head2 sort_by
  
      $json = $json->sort_by($code_ref)
      $json = $json->sort_by($subroutine_name)
  
  If you just want to sort keys (names) in JSON objects when you
  C<encode>, enable C<canonical> option (see above) that allows you to
  sort object keys alphabetically.
  
  If you do need to sort non-alphabetically for whatever reasons,
  you can give a code reference (or a subroutine name) to C<sort_by>,
  then the argument will be passed to Perl's C<sort> built-in function.
  
  As the sorting is done in the JSON::PP scope, you usually need to
  prepend C<JSON::PP::> to the subroutine name, and the special variables
  C<$a> and C<$b> used in the subrontine used by C<sort> function.
  
  Example:
  
     my %ORDER = (id => 1, class => 2, name => 3);
     $json->sort_by(sub {
         ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999)
         or $JSON::PP::a cmp $JSON::PP::b
     });
     print $json->encode([
         {name => 'CPAN', id => 1, href => 'http://cpan.org'}
     ]);
     # [{"id":1,"name":"CPAN","href":"http://cpan.org"}]
  
  Note that C<sort_by> affects all the plain hashes in the data structure.
  If you need finer control, C<tie> necessary hashes with a module that
  implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>).
  C<canonical> and C<sort_by> don't affect the key order in C<tie>d
  hashes.
  
     use Hash::Ordered;
     tie my %hash, 'Hash::Ordered',
         (name => 'CPAN', id => 1, href => 'http://cpan.org');
     print $json->encode([\%hash]);
     # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept
  
  =head1 INCREMENTAL PARSING
  
  This section is also taken from JSON::XS.
  
  In some cases, there is the need for incremental parsing of JSON
  texts. While this module always has to keep both JSON text and resulting
  Perl data structure in memory at one time, it 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).
  
  JSON::PP 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 mismatched
  parentheses. 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 erroneous 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 (other than
  whitespace) 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::PP->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.
  
  That means you can only use this function to look at or manipulate text
  before or after complete JSON objects, not while the parser is in the
  middle of parsing a JSON object.
  
  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).
  
  =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 so far. 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.
  
  The difference to C<incr_reset> is that only text until the parse error
  occurred is removed.
  
  =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 to repeatedly parse JSON objects and want to
  ignore any trailing data, which means you have to reset the parser after
  each successful decode.
  
  =head1 MAPPING
  
  Most of this section is also taken from JSON::XS.
  
  This section describes how JSON::PP maps Perl values to JSON values and
  vice versa. These mappings are designed to "do the right thing" in most
  circumstances automatically, preserving round-tripping characteristics
  (what you put in comes out as something equivalent).
  
  For the more enlightened: note that in the following descriptions,
  lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
  refers to the abstract Perl language itself.
  
  =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 preserve 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, JSON::PP 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 to a 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, JSON::PP only guarantees precision up to but not including
  the least significant bit.
  
  When C<allow_bignum> is enabled, big integer values and any numeric
  values will be converted into L<Math::BigInt> and L<Math::BigFloat>
  objects respectively, without becoming string scalars or losing
  precision.
  
  =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 whether a scalar is a JSON boolean by using
  the C<JSON::PP::is_bool> function.
  
  =item null
  
  A JSON null atom becomes C<undef> in Perl.
  
  =item shell-style comments (C<< # I<text> >>)
  
  As a nonstandard extension to the JSON syntax that is enabled by the
  C<relaxed> setting, shell-style comments are allowed. They can start
  anywhere outside strings and go till the end of the line.
  
  =item tagged values (C<< (I<tag>)I<value> >>).
  
  Another nonstandard extension to the JSON syntax, enabled with the
  C<allow_tags> setting, are tagged values. In this implementation, the
  I<tag> must be a perl package/class name encoded as a JSON string, and the
  I<value> must be a JSON array encoding optional constructor arguments.
  
  See L<OBJECT SERIALISATION>, below, for details.
  
  =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. JSON::PP can optionally sort the hash keys
  (determined by the I<canonical> flag and/or I<sort_by> property), so
  the same data structure will serialise to the same JSON text (given
  same settings and version of JSON::PP), 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::PP::false> and C<JSON::PP::true> to improve
  readability.
  
     to_json [\0, JSON::PP::true]      # yields [false,true]
  
  =item JSON::PP::true, JSON::PP::false
  
  These special values become JSON true and JSON false values,
  respectively. You can also use C<\1> and C<\0> directly if you want.
  
  =item JSON::PP::null
  
  This special value becomes JSON null.
  
  =item blessed objects
  
  Blessed objects are not directly representable in JSON, but C<JSON::PP>
  allows various ways of handling objects. See L<OBJECT SERIALISATION>,
  below, for details.
  
  =item simple scalars
  
  Simple Perl scalars (any scalar that is not a reference) are the most
  difficult objects to encode: 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 JSON 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
                  # (but for older perls)
  
  You can force the type to be a JSON 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 choice is yours.
  
  You can not currently force the type in other, less obscure, ways.
  
  Since version 2.91_01, JSON::PP uses a different number detection logic
  that converts a scalar that is possible to turn into a number safely.
  The new logic is slightly faster, and tends to help people who use older
  perl or who want to encode complicated data structure. However, this may
  results in a different JSON text from the one JSON::XS encodes (and
  thus may break tests that compare entire JSON texts). If you do
  need the previous behavior for compatibility or for finer control,
  set PERL_JSON_PP_USE_B environmental variable to true before you
  C<use> JSON::PP (or JSON.pm).
  
  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.
  
  JSON::PP (and JSON::XS) trusts what you pass to C<encode> method
  (or C<encode_json> function) is a clean, validated data structure with
  values that can be represented as valid JSON values only, because it's
  not from an external data source (as opposed to JSON texts you pass to
  C<decode> or C<decode_json>, which JSON::PP considers tainted and
  doesn't trust). As JSON::PP doesn't know exactly what you and consumers
  of your JSON texts want the unexpected values to be (you may want to
  convert them into null, or to stringify them with or without
  normalisation (string representation of infinities/NaN may vary
  depending on platforms), or to croak without conversion), you're advised
  to do what you and your consumers need before you encode, and also not
  to numify values that may start with values that look like a number
  (including infinities/NaN), without validating.
  
  =back
  
  =head2 OBJECT SERIALISATION
  
  As JSON cannot directly represent Perl objects, you have to choose between
  a pure JSON representation (without the ability to deserialise the object
  automatically again), and a nonstandard extension to the JSON syntax,
  tagged values.
  
  =head3 SERIALISATION
  
  What happens when C<JSON::PP> encounters a Perl object depends on the
  C<allow_blessed>, C<convert_blessed>, C<allow_tags> and C<allow_bignum>
  settings, which are used in this order:
  
  =over 4
  
  =item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method.
  
  In this case, C<JSON::PP> creates a tagged JSON value, using a nonstandard
  extension to the JSON syntax.
  
  This works by invoking the C<FREEZE> method on the object, with the first
  argument being the object to serialise, and the second argument being the
  constant string C<JSON> to distinguish it from other serialisers.
  
  The C<FREEZE> method can return any number of values (i.e. zero or
  more). These values and the paclkage/classname of the object will then be
  encoded as a tagged JSON value in the following format:
  
     ("classname")[FREEZE return values...]
  
  e.g.:
  
     ("URI")["http://www.google.com/"]
     ("MyDate")[2013,10,29]
     ("ImageData::JPEG")["Z3...VlCg=="]
  
  For example, the hypothetical C<My::Object> C<FREEZE> method might use the
  objects C<type> and C<id> members to encode the object:
  
     sub My::Object::FREEZE {
        my ($self, $serialiser) = @_;
  
        ($self->{type}, $self->{id})
     }
  
  =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
  
  In this case, the C<TO_JSON> method of the object is invoked in scalar
  context. It must return a single scalar that can be directly encoded into
  JSON. This scalar replaces the object in the JSON text.
  
  For example, the following C<TO_JSON> method will convert all L<URI>
  objects to JSON strings when serialised. The fact that these values
  originally were L<URI> objects is lost.
  
     sub URI::TO_JSON {
        my ($uri) = @_;
        $uri->as_string
     }
  
  =item 3. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
  
  The object will be serialised as a JSON number value.
  
  =item 4. C<allow_blessed> is enabled.
  
  The object will be serialised as a JSON null value.
  
  =item 5. none of the above
  
  If none of the settings are enabled or the respective methods are missing,
  C<JSON::PP> throws an exception.
  
  =back
  
  =head3 DESERIALISATION
  
  For deserialisation there are only two cases to consider: either
  nonstandard tagging was used, in which case C<allow_tags> decides,
  or objects cannot be automatically be deserialised, in which
  case you can use postprocessing or the C<filter_json_object> or
  C<filter_json_single_key_object> callbacks to get some real objects our of
  your JSON.
  
  This section only considers the tagged value case: a tagged JSON object
  is encountered during decoding and C<allow_tags> is disabled, a parse
  error will result (as if tagged values were not part of the grammar).
  
  If C<allow_tags> is enabled, C<JSON::PP> will look up the C<THAW> method
  of the package/classname used during serialisation (it will not attempt
  to load the package as a Perl module). If there is no such method, the
  decoding will fail with an error.
  
  Otherwise, the C<THAW> method is invoked with the classname as first
  argument, the constant string C<JSON> as second argument, and all the
  values from the JSON array (the values originally returned by the
  C<FREEZE> method) as remaining arguments.
  
  The method must then return the object. While technically you can return
  any Perl scalar, you might have to enable the C<allow_nonref> setting to
  make that work in all cases, so better return an actual blessed reference.
  
  As an example, let's implement a C<THAW> function that regenerates the
  C<My::Object> from the C<FREEZE> example earlier:
  
     sub My::Object::THAW {
        my ($class, $serialiser, $type, $id) = @_;
  
        $class->new (type => $type, id => $id)
     }
  
  
  =head1 ENCODING/CODESET FLAG NOTES
  
  This section is taken from JSON::XS.
  
  The interested reader might have seen a number of flags that signify
  encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
  some confusion on what these do, so here is a short comparison:
  
  C<utf8> controls whether the JSON text created by C<encode> (and expected
  by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
  control whether C<encode> escapes character values outside their respective
  codeset range. Neither of these flags conflict with each other, although
  some combinations make less sense than others.
  
  Care has been taken to make all flags symmetrical with respect to
  C<encode> and C<decode>, that is, texts encoded with any combination of
  these flag values will be correctly decoded when the same flags are used
  - in general, if you use different flag settings while encoding vs. when
  decoding you likely have a bug somewhere.
  
  Below comes a verbose discussion of these flags. Note that a "codeset" is
  simply an abstract set of character-codepoint pairs, while an encoding
  takes those codepoint numbers and I<encodes> them, in our case into
  octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
  and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
  the same time, which can be confusing.
  
  =over 4
  
  =item C<utf8> flag disabled
  
  When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
  and expect Unicode strings, that is, characters with high ordinal Unicode
  values (> 255) will be encoded as such characters, and likewise such
  characters are decoded as-is, no changes to them will be done, except
  "(re-)interpreting" them as Unicode codepoints or Unicode characters,
  respectively (to Perl, these are the same thing in strings unless you do
  funny/weird/dumb stuff).
  
  This is useful when you want to do the encoding yourself (e.g. when you
  want to have UTF-16 encoded JSON texts) or when some other layer does
  the encoding for you (for example, when printing to a terminal using a
  filehandle that transparently encodes to UTF-8 you certainly do NOT want
  to UTF-8 encode your data first and have Perl encode it another time).
  
  =item C<utf8> flag enabled
  
  If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
  characters using the corresponding UTF-8 multi-byte sequence, and will
  expect your input strings to be encoded as UTF-8, that is, no "character"
  of the input string must have any value > 255, as UTF-8 does not allow
  that.
  
  The C<utf8> flag therefore switches between two modes: disabled means you
  will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
  octet/binary string in Perl.
  
  =item C<latin1> or C<ascii> flags enabled
  
  With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
  with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
  characters as specified by the C<utf8> flag.
  
  If C<utf8> is disabled, then the result is also correctly encoded in those
  character sets (as both are proper subsets of Unicode, meaning that a
  Unicode string with all character values < 256 is the same thing as a
  ISO-8859-1 string, and a Unicode string with all character values < 128 is
  the same thing as an ASCII string in Perl).
  
  If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
  regardless of these flags, just some more characters will be escaped using
  C<\uXXXX> then before.
  
  Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
  encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
  encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
  a subset of Unicode), while ASCII is.
  
  Surprisingly, C<decode> will ignore these flags and so treat all input
  values as governed by the C<utf8> flag. If it is disabled, this allows you
  to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
  Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
  
  So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
  they only govern when the JSON output engine escapes a character or not.
  
  The main use for C<latin1> is to relatively efficiently store binary data
  as JSON, at the expense of breaking compatibility with most JSON decoders.
  
  The main use for C<ascii> is to force the output to not contain characters
  with values > 127, which means you can interpret the resulting string
  as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
  8-bit-encoding, and still get the same data structure back. This is useful
  when your channel for JSON transfer is not 8-bit clean or the encoding
  might be mangled in between (e.g. in mail), and works because ASCII is a
  proper subset of most 8-bit and multibyte encodings in use in the world.
  
  =back
  
  =head1 BUGS
  
  Please report bugs on a specific behavior of this module to RT or GitHub
  issues (preferred):
  
  L<https://github.com/makamaka/JSON-PP/issues>
  
  L<https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON-PP>
  
  As for new features and requests to change common behaviors, please
  ask the author of JSON::XS (Marc Lehmann, E<lt>schmorp[at]schmorp.deE<gt>)
  first, by email (important!), to keep compatibility among JSON.pm backends.
  
  Generally speaking, if you need something special for you, you are advised
  to create a new module, maybe based on L<JSON::Tiny>, which is smaller and
  written in a much cleaner way than this module.
  
  =head1 SEE ALSO
  
  The F<json_pp> command line utility for quick experiments.
  
  L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives.
  L<JSON> and L<JSON::MaybeXS> for easy migration.
  
  L<JSON::PP::Compat5005> and L<JSON::PP::Compat5006> for older perl users.
  
  RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
  
  RFC7159 (L<http://www.ietf.org/rfc/rfc7159.txt>)
  
  RFC8259 (L<http://www.ietf.org/rfc/rfc8259.txt>)
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  =head1 CURRENT MAINTAINER
  
  Kenichi Ishigaki, E<lt>ishigaki[at]cpan.orgE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2016 by Makamaka Hannyaharamitu
  
  Most of the documentation is taken from JSON::XS by Marc Lehmann
  
  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';
  package JSON::PP::Boolean;
  
  use strict;
  use warnings;
  use overload ();
  overload::unimport('overload', qw(0+ ++ -- fallback));
  overload::import('overload',
      "0+"     => sub { ${$_[0]} },
      "++"     => sub { $_[0] = ${$_[0]} + 1 },
      "--"     => sub { $_[0] = ${$_[0]} - 1 },
      fallback => 1,
  );
  
  our $VERSION = '4.16';
  
  1;
  
  __END__
  
  =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.
  
  =head1 AUTHOR
  
  This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
  
JSON_PP_BOOLEAN

$fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY';
  package lib::core::only;
  
  use strict;
  use warnings FATAL => 'all';
  use Config;
  
  sub import {
    @INC = @Config{qw(privlibexp archlibexp)};
    return
  }
  
  =head1 NAME
  
  lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs
  
  =head1 SYNOPSIS
  
    use lib::core::only; # now @INC contains only the two core directories
  
  To get only the core directories plus the ones for the local::lib in scope:
  
    $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl
  
  To attempt to do a self-contained build (but note this will not reliably
  propagate into subprocesses, see the CAVEATS below):
  
    $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan
  
  Please note that it is necessary to use C<local::lib> twice for this to work.
  First so that C<lib::core::only> doesn't prevent C<local::lib> from loading
  (it's not currently in core) and then again after C<lib::core::only> so that
  the local paths are not removed.
  
  =head1 DESCRIPTION
  
  lib::core::only is simply a shortcut to say "please reduce my @INC to only
  the core lib and archlib (architecture-specific lib) directories of this perl".
  
  You might want to do this to ensure a local::lib contains only the code you
  need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known
  bad vendor packages.
  
  You might want to use this to try and install a self-contained tree of perl
  modules. Be warned that that probably won't work (see L</CAVEATS>).
  
  This module was extracted from L<local::lib|local::lib>'s --self-contained
  feature, and contains the only part that ever worked. I apologise to anybody
  who thought anything else did.
  
  =head1 CAVEATS
  
  This does B<not> propagate properly across perl invocations like local::lib's
  stuff does. It can't. It's only a module import, so it B<only affects the
  specific perl VM instance in which you load and import() it>.
  
  If you want to cascade it across invocations, you can set the PERL5OPT
  environment variable to '-Mlib::core::only' and it'll sort of work. But be
  aware that taint mode ignores this, so some modules' build and test code
  probably will as well.
  
  You also need to be aware that perl's command line options are not processed
  in order - -I options take effect before -M options, so
  
    perl -Mlib::core::only -Ilib
  
  is unlike to do what you want - it's exactly equivalent to:
  
    perl -Mlib::core::only
  
  If you want to combine a core-only @INC with additional paths, you need to
  add the additional paths using -M options and the L<lib|lib> module:
  
    perl -Mlib::core::only -Mlib=lib
  
    # or if you're trying to test compiled code:
  
    perl -Mlib::core::only -Mblib
  
  For more information on the impossibility of sanely propagating this across
  module builds without help from the build program, see
  L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways
  to achieve the old --self-contained feature's results, look at
  L<App::FatPacker|App::FatPacker>'s tree function, and at
  L<App::cpanminus|cpanm>'s --local-lib-contained feature.
  
  =head1 AUTHOR
  
  Matt S. Trout <mst@shadowcat.co.uk>
  
  =head1 LICENSE
  
  This library is free software under the same terms as perl itself.
  
  =head1 COPYRIGHT
  
  (c) 2010 the lib::core::only L</AUTHOR> as specified above.
  
  =cut
  
  1;
LIB_CORE_ONLY

$fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB';
  package local::lib;
  use 5.006;
  BEGIN {
    if ($ENV{RELEASE_TESTING}) {
      require strict;
      strict->import;
      require warnings;
      warnings->import;
    }
  }
  use Config ();
  
  our $VERSION = '2.000029';
  $VERSION =~ tr/_//d;
  
  BEGIN {
    *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')
      ? sub(){1} : sub(){0};
    # punt on these systems
    *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})
      ? sub(){1} : sub(){0};
  }
  my $_archname = $Config::Config{archname};
  my $_version = $Config::Config{version};
  my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list};
  my $_path_sep = $Config::Config{path_sep};
  
  our $_DIR_JOIN = _WIN32 ? '\\' : '/';
  our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]}
                                                : qr{/};
  our $_ROOT = _WIN32 ? do {
    my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};
    qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT};
  } : qr{^/};
  our $_PERL;
  
  sub _perl {
    if (!$_PERL) {
      # untaint and validate
      ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/;
      $_PERL = 'perl'
        if $exe !~ /perl/;
      if (_is_abs($_PERL)) {
      }
      elsif (-x $Config::Config{perlpath}) {
        $_PERL = $Config::Config{perlpath};
      }
      elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) {
        $_PERL = _rel2abs($_PERL);
      }
      else {
        ($_PERL) =
          map { /(.*)/ }
          grep { -x $_ }
          map { ($_, _WIN32 ? ("$_.exe") : ()) }
          map { join($_DIR_JOIN, $_, $_PERL) }
          split /\Q$_path_sep\E/, $ENV{PATH};
      }
    }
    $_PERL;
  }
  
  sub _cwd {
    if (my $cwd
      = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd
      : defined &Cwd::cwd     ? \&Cwd::cwd
      : undef
    ) {
      no warnings 'redefine';
      *_cwd = $cwd;
      goto &$cwd;
    }
    my $drive = shift;
    return Win32::GetCwd()
      if _WIN32 && defined &Win32::GetCwd && !$drive;
    local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
    delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
    my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }"
                     : 'getcwd';
    my $perl = _perl;
    my $cwd = `"$perl" -MCwd -le "print $cmd"`;
    chomp $cwd;
    if (!length $cwd && $drive) {
      $cwd = $drive;
    }
    $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;
    $cwd;
  }
  
  sub _catdir {
    if (_USE_FSPEC) {
      require File::Spec;
      File::Spec->catdir(@_);
    }
    else {
      my $dir = join($_DIR_JOIN, @_);
      $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;
      $dir;
    }
  }
  
  sub _is_abs {
    if (_USE_FSPEC) {
      require File::Spec;
      File::Spec->file_name_is_absolute($_[0]);
    }
    else {
      $_[0] =~ $_ROOT;
    }
  }
  
  sub _rel2abs {
    my ($dir, $base) = @_;
    return $dir
      if _is_abs($dir);
  
    $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1")
          : $base                              ? _rel2abs($base)
                                               : _cwd;
    return _catdir($base, $dir);
  }
  
  our $_DEVNULL;
  sub _devnull {
    return $_DEVNULL ||=
      _USE_FSPEC      ? (require File::Spec, File::Spec->devnull)
      : _WIN32        ? 'nul'
      : $^O eq 'os2'  ? '/dev/nul'
      : '/dev/null';
  }
  
  sub import {
    my ($class, @args) = @_;
    if ($0 eq '-') {
      push @args, @ARGV;
      require Cwd;
    }
  
    my @steps;
    my %opts;
    my %attr;
    my $shelltype;
  
    while (@args) {
      my $arg = shift @args;
      # check for lethal dash first to stop processing before causing problems
      # the fancy dash is U+2212 or \xE2\x88\x92
      if ($arg =~ /\xE2\x88\x92/) {
        die <<'DEATH';
  WHOA THERE! It looks like you've got some fancy dashes in your commandline!
  These are *not* the traditional -- dashes that software recognizes. You
  probably got these by copy-pasting from the perldoc for this module as
  rendered by a UTF8-capable formatter. This most typically happens on an OS X
  terminal, but can happen elsewhere too. Please try again after replacing the
  dashes with normal minus signs.
  DEATH
      }
      elsif ($arg eq '--self-contained') {
        die <<'DEATH';
  FATAL: The local::lib --self-contained flag has never worked reliably and the
  original author, Mark Stosberg, was unable or unwilling to maintain it. As
  such, this flag has been removed from the local::lib codebase in order to
  prevent misunderstandings and potentially broken builds. The local::lib authors
  recommend that you look at the lib::core::only module shipped with this
  distribution in order to create a more robust environment that is equivalent to
  what --self-contained provided (although quite possibly not what you originally
  thought it provided due to the poor quality of the documentation, for which we
  apologise).
  DEATH
      }
      elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) {
        my $path = defined $1 ? $1 : shift @args;
        push @steps, ['deactivate', $path];
      }
      elsif ( $arg eq '--deactivate-all' ) {
        push @steps, ['deactivate_all'];
      }
      elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) {
        $shelltype = defined $1 ? $1 : shift @args;
      }
      elsif ( $arg eq '--no-create' ) {
        $opts{no_create} = 1;
      }
      elsif ( $arg eq '--quiet' ) {
        $attr{quiet} = 1;
      }
      elsif ( $arg eq '--always' ) {
        $attr{always} = 1;
      }
      elsif ( $arg =~ /^--/ ) {
        die "Unknown import argument: $arg";
      }
      else {
        push @steps, ['activate', $arg, \%opts];
      }
    }
    if (!@steps) {
      push @steps, ['activate', undef, \%opts];
    }
  
    my $self = $class->new(%attr);
  
    for (@steps) {
      my ($method, @args) = @$_;
      $self = $self->$method(@args);
    }
  
    if ($0 eq '-') {
      print $self->environment_vars_string($shelltype);
      exit 0;
    }
    else {
      $self->setup_local_lib;
    }
  }
  
  sub new {
    my $class = shift;
    bless {@_}, $class;
  }
  
  sub clone {
    my $self = shift;
    bless {%$self, @_}, ref $self;
  }
  
  sub inc { $_[0]->{inc}     ||= \@INC }
  sub libs { $_[0]->{libs}   ||= [ \'PERL5LIB' ] }
  sub bins { $_[0]->{bins}   ||= [ \'PATH' ] }
  sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] }
  sub extra { $_[0]->{extra} ||= {} }
  sub quiet { $_[0]->{quiet} }
  
  sub _as_list {
    my $list = shift;
    grep length, map {
      !(ref $_ && ref $_ eq 'SCALAR') ? $_ : (
        defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_})
                          : ()
      )
    } ref $list ? @$list : $list;
  }
  sub _remove_from {
    my ($list, @remove) = @_;
    return @$list
      if !@remove;
    my %remove = map { $_ => 1 } @remove;
    grep !$remove{$_}, _as_list($list);
  }
  
  my @_lib_subdirs = (
    [$_version, $_archname],
    [$_version],
    [$_archname],
    (map [$_], @_inc_version_list),
    [],
  );
  
  sub install_base_bin_path {
    my ($class, $path) = @_;
    return _catdir($path, 'bin');
  }
  sub install_base_perl_path {
    my ($class, $path) = @_;
    return _catdir($path, 'lib', 'perl5');
  }
  sub install_base_arch_path {
    my ($class, $path) = @_;
    _catdir($class->install_base_perl_path($path), $_archname);
  }
  
  sub lib_paths_for {
    my ($class, $path) = @_;
    my $base = $class->install_base_perl_path($path);
    return map { _catdir($base, @$_) } @_lib_subdirs;
  }
  
  sub _mm_escape_path {
    my $path = shift;
    $path =~ s/\\/\\\\/g;
    if ($path =~ s/ /\\ /g) {
      $path = qq{"$path"};
    }
    return $path;
  }
  
  sub _mb_escape_path {
    my $path = shift;
    $path =~ s/\\/\\\\/g;
    return qq{"$path"};
  }
  
  sub installer_options_for {
    my ($class, $path) = @_;
    return (
      PERL_MM_OPT =>
        defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef,
      PERL_MB_OPT =>
        defined $path ? "--install_base "._mb_escape_path($path) : undef,
    );
  }
  
  sub active_paths {
    my ($self) = @_;
    $self = ref $self ? $self : $self->new;
  
    return grep {
      # screen out entries that aren't actually reflected in @INC
      my $active_ll = $self->install_base_perl_path($_);
      grep { $_ eq $active_ll } @{$self->inc};
    } _as_list($self->roots);
  }
  
  
  sub deactivate {
    my ($self, $path) = @_;
    $self = $self->new unless ref $self;
    $path = $self->resolve_path($path);
    $path = $self->normalize_path($path);
  
    my @active_lls = $self->active_paths;
  
    if (!grep { $_ eq $path } @active_lls) {
      warn "Tried to deactivate inactive local::lib '$path'\n";
      return $self;
    }
  
    my %args = (
      bins  => [ _remove_from($self->bins,
        $self->install_base_bin_path($path)) ],
      libs  => [ _remove_from($self->libs,
        $self->install_base_perl_path($path)) ],
      inc   => [ _remove_from($self->inc,
        $self->lib_paths_for($path)) ],
      roots => [ _remove_from($self->roots, $path) ],
    );
  
    $args{extra} = { $self->installer_options_for($args{roots}[0]) };
  
    $self->clone(%args);
  }
  
  sub deactivate_all {
    my ($self) = @_;
    $self = $self->new unless ref $self;
  
    my @active_lls = $self->active_paths;
  
    my %args;
    if (@active_lls) {
      %args = (
        bins => [ _remove_from($self->bins,
          map $self->install_base_bin_path($_), @active_lls) ],
        libs => [ _remove_from($self->libs,
          map $self->install_base_perl_path($_), @active_lls) ],
        inc => [ _remove_from($self->inc,
          map $self->lib_paths_for($_), @active_lls) ],
        roots => [ _remove_from($self->roots, @active_lls) ],
      );
    }
  
    $args{extra} = { $self->installer_options_for(undef) };
  
    $self->clone(%args);
  }
  
  sub activate {
    my ($self, $path, $opts) = @_;
    $opts ||= {};
    $self = $self->new unless ref $self;
    $path = $self->resolve_path($path);
    $self->ensure_dir_structure_for($path, { quiet => $self->quiet })
      unless $opts->{no_create};
  
    $path = $self->normalize_path($path);
  
    my @active_lls = $self->active_paths;
  
    if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) {
      $self = $self->deactivate($path);
    }
  
    my %args;
    if ($opts->{always} || !@active_lls || $active_lls[0] ne $path) {
      %args = (
        bins  => [ $self->install_base_bin_path($path), @{$self->bins} ],
        libs  => [ $self->install_base_perl_path($path), @{$self->libs} ],
        inc   => [ $self->lib_paths_for($path), @{$self->inc} ],
        roots => [ $path, @{$self->roots} ],
      );
    }
  
    $args{extra} = { $self->installer_options_for($path) };
  
    $self->clone(%args);
  }
  
  sub normalize_path {
    my ($self, $path) = @_;
    $path = ( Win32::GetShortPathName($path) || $path )
      if $^O eq 'MSWin32';
    return $path;
  }
  
  sub build_environment_vars_for {
    my $self = $_[0]->new->activate($_[1], { always => 1 });
    $self->build_environment_vars;
  }
  sub build_activate_environment_vars_for {
    my $self = $_[0]->new->activate($_[1], { always => 1 });
    $self->build_environment_vars;
  }
  sub build_deactivate_environment_vars_for {
    my $self = $_[0]->new->deactivate($_[1]);
    $self->build_environment_vars;
  }
  sub build_deact_all_environment_vars_for {
    my $self = $_[0]->new->deactivate_all;
    $self->build_environment_vars;
  }
  sub build_environment_vars {
    my $self = shift;
    (
      PATH                => join($_path_sep, _as_list($self->bins)),
      PERL5LIB            => join($_path_sep, _as_list($self->libs)),
      PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)),
      %{$self->extra},
    );
  }
  
  sub setup_local_lib_for {
    my $self = $_[0]->new->activate($_[1]);
    $self->setup_local_lib;
  }
  
  sub setup_local_lib {
    my $self = shift;
  
    # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid
    # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to
    # check in the other direction)
    require Carp::Heavy if $INC{'Carp.pm'};
  
    $self->setup_env_hash;
    @INC = @{$self->inc};
  }
  
  sub setup_env_hash_for {
    my $self = $_[0]->new->activate($_[1]);
    $self->setup_env_hash;
  }
  sub setup_env_hash {
    my $self = shift;
    my %env = $self->build_environment_vars;
    for my $key (keys %env) {
      if (defined $env{$key}) {
        $ENV{$key} = $env{$key};
      }
      else {
        delete $ENV{$key};
      }
    }
  }
  
  sub print_environment_vars_for {
    print $_[0]->environment_vars_string_for(@_[1..$#_]);
  }
  
  sub environment_vars_string_for {
    my $self = $_[0]->new->activate($_[1], { always => 1});
    $self->environment_vars_string;
  }
  sub environment_vars_string {
    my ($self, $shelltype) = @_;
  
    $shelltype ||= $self->guess_shelltype;
  
    my $extra = $self->extra;
    my @envs = (
      PATH                => $self->bins,
      PERL5LIB            => $self->libs,
      PERL_LOCAL_LIB_ROOT => $self->roots,
      map { $_ => $extra->{$_} } sort keys %$extra,
    );
    $self->_build_env_string($shelltype, \@envs);
  }
  
  sub _build_env_string {
    my ($self, $shelltype, $envs) = @_;
    my @envs = @$envs;
  
    my $build_method = "build_${shelltype}_env_declaration";
  
    my $out = '';
    while (@envs) {
      my ($name, $value) = (shift(@envs), shift(@envs));
      if (
          ref $value
          && @$value == 1
          && ref $value->[0]
          && ref $value->[0] eq 'SCALAR'
          && ${$value->[0]} eq $name) {
        next;
      }
      $out .= $self->$build_method($name, $value);
    }
    my $wrap_method = "wrap_${shelltype}_output";
    if ($self->can($wrap_method)) {
      return $self->$wrap_method($out);
    }
    return $out;
  }
  
  sub build_bourne_env_declaration {
    my ($class, $name, $args) = @_;
    my $value = $class->_interpolate($args, '${%s:-}', qr/["\\\$!`]/, '\\%s');
  
    if (!defined $value) {
      return qq{unset $name;\n};
    }
  
    $value =~ s/(^|\G|$_path_sep)\$\{$name:-\}$_path_sep/$1\${$name}\${$name:+$_path_sep}/g;
    $value =~ s/$_path_sep\$\{$name:-\}$/\${$name:+$_path_sep\${$name}}/;
  
    qq{${name}="$value"; export ${name};\n}
  }
  
  sub build_csh_env_declaration {
    my ($class, $name, $args) = @_;
    my ($value, @vars) = $class->_interpolate($args, '${%s}', qr/["\$]/, '"\\%s"');
    if (!defined $value) {
      return qq{unsetenv $name;\n};
    }
  
    my $out = '';
    for my $var (@vars) {
      $out .= qq{if ! \$?$name setenv $name '';\n};
    }
  
    my $value_without = $value;
    if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) {
      $out .= qq{if "\${$name}" != '' setenv $name "$value";\n};
      $out .= qq{if "\${$name}" == '' };
    }
    $out .= qq{setenv $name "$value_without";\n};
    return $out;
  }
  
  sub build_cmd_env_declaration {
    my ($class, $name, $args) = @_;
    my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s');
    if (!$value) {
      return qq{\@set $name=\n};
    }
  
    my $out = '';
    my $value_without = $value;
    if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) {
      $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};
      $out .= qq{\@if "%$name%"=="" };
    }
    $out .= qq{\@set "$name=$value_without"\n};
    return $out;
  }
  
  sub build_powershell_env_declaration {
    my ($class, $name, $args) = @_;
    my $value = $class->_interpolate($args, '$env:%s', qr/["\$]/, '`%s');
  
    if (!$value) {
      return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n};
    }
  
    my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};
    $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;
    $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;
  
    qq{\$env:$name = \$("$value");\n};
  }
  sub wrap_powershell_output {
    my ($class, $out) = @_;
    return $out || " \n";
  }
  
  sub build_fish_env_declaration {
    my ($class, $name, $args) = @_;
    my $value = $class->_interpolate($args, '$%s', qr/[\\"'$ ]/, '\\%s');
    if (!defined $value) {
      return qq{set -e $name;\n};
    }
  
    # fish has special handling for PATH, CDPATH, and MANPATH.  They are always
    # treated as arrays, and joined with ; when storing the environment.  Other
    # env vars can be arrays, but will be joined without a separator.  We only
    # really care about PATH, but might as well make this routine more general.
    if ($name =~ /^(?:CD|MAN)?PATH$/) {
      $value =~ s/$_path_sep/ /g;
      my $silent = $name =~ /^(?:CD)?PATH$/ ? " 2>"._devnull : '';
      return qq{set -x $name $value$silent;\n};
    }
  
    my $out = '';
    my $value_without = $value;
    if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
      $out .= qq{set -q $name; and set -x $name $value;\n};
      $out .= qq{set -q $name; or };
    }
    $out .= qq{set -x $name $value_without;\n};
    $out;
  }
  
  sub _interpolate {
    my ($class, $args, $var_pat, $escape, $escape_pat) = @_;
    return
      unless defined $args;
    my @args = ref $args ? @$args : $args;
    return
      unless @args;
    my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args;
    my $string = join $_path_sep, map {
      ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do {
        s/($escape)/sprintf($escape_pat, $1)/ge; $_;
      };
    } @args;
    return wantarray ? ($string, \@vars) : $string;
  }
  
  sub pipeline;
  
  sub pipeline {
    my @methods = @_;
    my $last = pop(@methods);
    if (@methods) {
      \sub {
        my ($obj, @args) = @_;
        $obj->${pipeline @methods}(
          $obj->$last(@args)
        );
      };
    } else {
      \sub {
        shift->$last(@_);
      };
    }
  }
  
  sub resolve_path {
    my ($class, $path) = @_;
  
    $path = $class->${pipeline qw(
      resolve_relative_path
      resolve_home_path
      resolve_empty_path
    )}($path);
  
    $path;
  }
  
  sub resolve_empty_path {
    my ($class, $path) = @_;
    if (defined $path) {
      $path;
    } else {
      '~/perl5';
    }
  }
  
  sub resolve_home_path {
    my ($class, $path) = @_;
    $path =~ /^~([^\/]*)/ or return $path;
    my $user = $1;
    my $homedir = do {
      if (! length($user) && defined $ENV{HOME}) {
        $ENV{HOME};
      }
      else {
        require File::Glob;
        File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE());
      }
    };
    unless (defined $homedir) {
      require Carp; require Carp::Heavy;
      Carp::croak(
        "Couldn't resolve homedir for "
        .(defined $user ? $user : 'current user')
      );
    }
    $path =~ s/^~[^\/]*/$homedir/;
    $path;
  }
  
  sub resolve_relative_path {
    my ($class, $path) = @_;
    _rel2abs($path);
  }
  
  sub ensure_dir_structure_for {
    my ($class, $path, $opts) = @_;
    $opts ||= {};
    my @dirs;
    foreach my $dir (
      $class->lib_paths_for($path),
      $class->install_base_bin_path($path),
    ) {
      my $d = $dir;
      while (!-d $d) {
        push @dirs, $d;
        require File::Basename;
        $d = File::Basename::dirname($d);
      }
    }
  
    warn "Attempting to create directory ${path}\n"
      if !$opts->{quiet} && @dirs;
  
    my %seen;
    foreach my $dir (reverse @dirs) {
      next
        if $seen{$dir}++;
  
      mkdir $dir
        or -d $dir
        or die "Unable to create $dir: $!"
    }
    return;
  }
  
  sub guess_shelltype {
    my $shellbin
      = defined $ENV{SHELL} && length $ENV{SHELL}
        ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1]
      : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} )
        ? 'bash'
      : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} )
        ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1]
      : ( $^O eq 'MSWin32' && !$ENV{PROMPT} )
        ? 'powershell.exe'
      : 'sh';
  
    for ($shellbin) {
      return
          /csh$/                   ? 'csh'
        : /fish$/                  ? 'fish'
        : /command(?:\.com)?$/i    ? 'cmd'
        : /cmd(?:\.exe)?$/i        ? 'cmd'
        : /4nt(?:\.exe)?$/i        ? 'cmd'
        : /powershell(?:\.exe)?$/i ? 'powershell'
                                   : 'bourne';
    }
  }
  
  1;
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  local::lib - create and use a local lib/ for perl modules with PERL5LIB
  
  =head1 SYNOPSIS
  
  In code -
  
    use local::lib; # sets up a local lib at ~/perl5
  
    use local::lib '~/foo'; # same, but ~/foo
  
    # Or...
    use FindBin;
    use local::lib "$FindBin::Bin/../support";  # app-local support library
  
  From the shell -
  
    # Install LWP and its missing dependencies to the '~/perl5' directory
    perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)'
  
    # Just print out useful shell commands
    $ perl -Mlocal::lib
    PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT;
    PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT;
    PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB;
    PATH="/home/username/perl5/bin:$PATH"; export PATH;
    PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT;
  
  From a F<.bash_profile> or F<.bashrc> file -
  
    eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"
  
  =head2 The bootstrapping technique
  
  A typical way to install local::lib is using what is known as the
  "bootstrapping" technique.  You would do this if your system administrator
  hasn't already installed local::lib.  In this case, you'll need to install
  local::lib in your home directory.
  
  Even if you do have administrative privileges, you will still want to set up your
  environment variables, as discussed in step 4. Without this, you would still
  install the modules into the system CPAN installation and also your Perl scripts
  will not use the lib/ path you bootstrapped with local::lib.
  
  By default local::lib installs itself and the CPAN modules into ~/perl5.
  
  Windows users must also see L</Differences when using this module under Win32>.
  
  =over 4
  
  =item 1.
  
  Download and unpack the local::lib tarball from CPAN (search for "Download"
  on the CPAN page about local::lib).  Do this as an ordinary user, not as root
  or administrator.  Unpack the file in your home directory or in any other
  convenient location.
  
  =item 2.
  
  Run this:
  
    perl Makefile.PL --bootstrap
  
  If the system asks you whether it should automatically configure as much
  as possible, you would typically answer yes.
  
  =item 3.
  
  Run this: (local::lib assumes you have make installed on your system)
  
    make test && make install
  
  =item 4.
  
  Now we need to setup the appropriate environment variables, so that Perl
  starts using our newly generated lib/ directory. If you are using bash or
  any other Bourne shells, you can add this to your shell startup script this
  way:
  
    echo 'eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"' >>~/.bashrc
  
  If you are using C shell, you can do this as follows:
  
    % echo $SHELL
    /bin/csh
    $ echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc
  
  After writing your shell configuration file, be sure to re-read it to get the
  changed settings into your current shell's environment. Bourne shells use
  C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>.
  
  =back
  
  =head3 Bootstrapping into an alternate directory
  
  In order to install local::lib into a directory other than the default, you need
  to specify the name of the directory when you call bootstrap.  Then, when
  setting up the environment variables, both perl and local::lib must be told the
  location of the bootstrap directory.  The setup process would look as follows:
  
    perl Makefile.PL --bootstrap=~/foo
    make test && make install
    echo 'eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc
    . ~/.bashrc
  
  =head3 Other bootstrapping options
  
  If you're on a slower machine, or are operating under draconian disk space
  limitations, you can disable the automatic generation of manpages from POD when
  installing modules by using the C<--no-manpages> argument when bootstrapping:
  
    perl Makefile.PL --bootstrap --no-manpages
  
  To avoid doing several bootstrap for several Perl module environments on the
  same account, for example if you use it for several different deployed
  applications independently, you can use one bootstrapped local::lib
  installation to install modules in different directories directly this way:
  
    cd ~/mydir1
    perl -Mlocal::lib=./
    eval $(perl -Mlocal::lib=./)  ### To set the environment for this shell alone
    printenv                      ### You will see that ~/mydir1 is in the PERL5LIB
    perl -MCPAN -e install ...    ### whatever modules you want
    cd ../mydir2
    ... REPEAT ...
  
  If you use F<.bashrc> to activate a local::lib automatically, the local::lib
  will be re-enabled in any sub-shells used, overriding adjustments you may have
  made in the parent shell.  To avoid this, you can initialize the local::lib in
  F<.bash_profile> rather than F<.bashrc>, or protect the local::lib invocation
  with a C<$SHLVL> check:
  
    [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"
  
  If you are working with several C<local::lib> environments, you may want to
  remove some of them from the current environment without disturbing the others.
  You can deactivate one environment like this (using bourne sh):
  
    eval $(perl -Mlocal::lib=--deactivate,~/path)
  
  which will generate and run the commands needed to remove C<~/path> from your
  various search paths. Whichever environment was B<activated most recently> will
  remain the target for module installations. That is, if you activate
  C<~/path_A> and then you activate C<~/path_B>, new modules you install will go
  in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed
  into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be
  installed in C<~/pathB> because pathB was activated later.
  
  You can also ask C<local::lib> to clean itself completely out of the current
  shell's environment with the C<--deactivate-all> option.
  For multiple environments for multiple apps you may need to include a modified
  version of the C<< use FindBin >> instructions in the "In code" sample above.
  If you did something like the above, you have a set of Perl modules at C<<
  ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>,
  you need to tell it where to find the modules you installed for it at C<<
  ~/mydir1/lib >>.
  
  In C<< ~/mydir1/scripts/myscript.pl >>:
  
    use strict;
    use warnings;
    use local::lib "$FindBin::Bin/..";  ### points to ~/mydir1 and local::lib finds lib
    use lib "$FindBin::Bin/../lib";     ### points to ~/mydir1/lib
  
  Put this before any BEGIN { ... } blocks that require the modules you installed.
  
  =head2 Differences when using this module under Win32
  
  To set up the proper environment variables for your current session of
  C<CMD.exe>, you can use this:
  
    C:\>perl -Mlocal::lib
    set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5
    set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
    set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5
    set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%
  
    ### To set the environment for this shell alone
    C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat
    ### instead of $(perl -Mlocal::lib=./)
  
  If you want the environment entries to persist, you'll need to add them to the
  Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>.
  
  The "~" is translated to the user's profile directory (the directory named for
  the user under "Documents and Settings" (Windows XP or earlier) or "Users"
  (Windows Vista or later)) unless $ENV{HOME} exists. After that, the home
  directory is translated to a short name (which means the directory must exist)
  and the subdirectories are created.
  
  =head3 PowerShell
  
  local::lib also supports PowerShell, and can be used with the
  C<Invoke-Expression> cmdlet.
  
    Invoke-Expression "$(perl -Mlocal::lib)"
  
  =head1 RATIONALE
  
  The version of a Perl package on your machine is not always the version you
  need.  Obviously, the best thing to do would be to update to the version you
  need.  However, you might be in a situation where you're prevented from doing
  this.  Perhaps you don't have system administrator privileges; or perhaps you
  are using a package management system such as Debian, and nobody has yet gotten
  around to packaging up the version you need.
  
  local::lib solves this problem by allowing you to create your own directory of
  Perl packages downloaded from CPAN (in a multi-user system, this would typically
  be within your own home directory).  The existing system Perl installation is
  not affected; you simply invoke Perl with special options so that Perl uses the
  packages in your own local package directory rather than the system packages.
  local::lib arranges things so that your locally installed version of the Perl
  packages takes precedence over the system installation.
  
  If you are using a package management system (such as Debian), you don't need to
  worry about Debian and CPAN stepping on each other's toes.  Your local version
  of the packages will be written to an entirely separate directory from those
  installed by Debian.
  
  =head1 DESCRIPTION
  
  This module provides a quick, convenient way of bootstrapping a user-local Perl
  module library located within the user's home directory. It also constructs and
  prints out for the user the list of environment variables using the syntax
  appropriate for the user's current shell (as specified by the C<SHELL>
  environment variable), suitable for directly adding to one's shell
  configuration file.
  
  More generally, local::lib allows for the bootstrapping and usage of a
  directory containing Perl modules outside of Perl's C<@INC>. This makes it
  easier to ship an application with an app-specific copy of a Perl module, or
  collection of modules. Useful in cases like when an upstream maintainer hasn't
  applied a patch to a module of theirs that you need for your application.
  
  On import, local::lib sets the following environment variables to appropriate
  values:
  
  =over 4
  
  =item PERL_MB_OPT
  
  =item PERL_MM_OPT
  
  =item PERL5LIB
  
  =item PATH
  
  =item PERL_LOCAL_LIB_ROOT
  
  =back
  
  When possible, these will be appended to instead of overwritten entirely.
  
  These values are then available for reference by any code after import.
  
  =head1 CREATING A SELF-CONTAINED SET OF MODULES
  
  See L<lib::core::only> for one way to do this - but note that
  there are a number of caveats, and the best approach is always to perform a
  build against a clean perl (i.e. site and vendor as close to empty as possible).
  
  =head1 IMPORT OPTIONS
  
  Options are values that can be passed to the C<local::lib> import besides the
  directory to use. They are specified as C<use local::lib '--option'[, path];>
  or C<perl -Mlocal::lib=--option[,path]>.
  
  =head2 --deactivate
  
  Remove the chosen path (or the default path) from the module search paths if it
  was added by C<local::lib>, instead of adding it.
  
  =head2 --deactivate-all
  
  Remove all directories that were added to search paths by C<local::lib> from the
  search paths.
  
  =head2 --quiet
  
  Don't output any messages about directories being created.
  
  =head2 --always
  
  Always add directories to environment variables, ignoring if they are already
  included.
  
  =head2 --shelltype
  
  Specify the shell type to use for output.  By default, the shell will be
  detected based on the environment.  Should be one of: C<bourne>, C<csh>,
  C<cmd>, or C<powershell>.
  
  =head2 --no-create
  
  Prevents C<local::lib> from creating directories when activating dirs.  This is
  likely to cause issues on Win32 systems.
  
  =head1 CLASS METHODS
  
  =head2 ensure_dir_structure_for
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: None
  
  =back
  
  Attempts to create a local::lib directory, including subdirectories and all
  required parent directories. Throws an exception on failure.
  
  =head2 print_environment_vars_for
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: None
  
  =back
  
  Prints to standard output the variables listed above, properly set to use the
  given path as the base directory.
  
  =head2 build_environment_vars_for
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: %environment_vars
  
  =back
  
  Returns a hash with the variables listed above, properly set to use the
  given path as the base directory.
  
  =head2 setup_env_hash_for
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: None
  
  =back
  
  Constructs the C<%ENV> keys for the given path, by calling
  L</build_environment_vars_for>.
  
  =head2 active_paths
  
  =over 4
  
  =item Arguments: None
  
  =item Return value: @paths
  
  =back
  
  Returns a list of active C<local::lib> paths, according to the
  C<PERL_LOCAL_LIB_ROOT> environment variable and verified against
  what is really in C<@INC>.
  
  =head2 install_base_perl_path
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $install_base_perl_path
  
  =back
  
  Returns a path describing where to install the Perl modules for this local
  library installation. Appends the directories C<lib> and C<perl5> to the given
  path.
  
  =head2 lib_paths_for
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: @lib_paths
  
  =back
  
  Returns the list of paths perl will search for libraries, given a base path.
  This includes the base path itself, the architecture specific subdirectory, and
  perl version specific subdirectories.  These paths may not all exist.
  
  =head2 install_base_bin_path
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $install_base_bin_path
  
  =back
  
  Returns a path describing where to install the executable programs for this
  local library installation. Appends the directory C<bin> to the given path.
  
  =head2 installer_options_for
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: %installer_env_vars
  
  =back
  
  Returns a hash of environment variables that should be set to cause
  installation into the given path.
  
  =head2 resolve_empty_path
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $base_path
  
  =back
  
  Builds and returns the base path into which to set up the local module
  installation. Defaults to C<~/perl5>.
  
  =head2 resolve_home_path
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $home_path
  
  =back
  
  Attempts to find the user's home directory.
  If no definite answer is available, throws an exception.
  
  =head2 resolve_relative_path
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $absolute_path
  
  =back
  
  Translates the given path into an absolute path.
  
  =head2 resolve_path
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $absolute_path
  
  =back
  
  Calls the following in a pipeline, passing the result from the previous to the
  next, in an attempt to find where to configure the environment for a local
  library installation: L</resolve_empty_path>, L</resolve_home_path>,
  L</resolve_relative_path>. Passes the given path argument to
  L</resolve_empty_path> which then returns a result that is passed to
  L</resolve_home_path>, which then has its result passed to
  L</resolve_relative_path>. The result of this final call is returned from
  L</resolve_path>.
  
  =head1 OBJECT INTERFACE
  
  =head2 new
  
  =over 4
  
  =item Arguments: %attributes
  
  =item Return value: $local_lib
  
  =back
  
  Constructs a new C<local::lib> object, representing the current state of
  C<@INC> and the relevant environment variables.
  
  =head1 ATTRIBUTES
  
  =head2 roots
  
  An arrayref representing active C<local::lib> directories.
  
  =head2 inc
  
  An arrayref representing C<@INC>.
  
  =head2 libs
  
  An arrayref representing the PERL5LIB environment variable.
  
  =head2 bins
  
  An arrayref representing the PATH environment variable.
  
  =head2 extra
  
  A hashref of extra environment variables (e.g. C<PERL_MM_OPT> and
  C<PERL_MB_OPT>)
  
  =head2 no_create
  
  If set, C<local::lib> will not try to create directories when activating them.
  
  =head1 OBJECT METHODS
  
  =head2 clone
  
  =over 4
  
  =item Arguments: %attributes
  
  =item Return value: $local_lib
  
  =back
  
  Constructs a new C<local::lib> object based on the existing one, overriding the
  specified attributes.
  
  =head2 activate
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $new_local_lib
  
  =back
  
  Constructs a new instance with the specified path active.
  
  =head2 deactivate
  
  =over 4
  
  =item Arguments: $path
  
  =item Return value: $new_local_lib
  
  =back
  
  Constructs a new instance with the specified path deactivated.
  
  =head2 deactivate_all
  
  =over 4
  
  =item Arguments: None
  
  =item Return value: $new_local_lib
  
  =back
  
  Constructs a new instance with all C<local::lib> directories deactivated.
  
  =head2 environment_vars_string
  
  =over 4
  
  =item Arguments: [ $shelltype ]
  
  =item Return value: $shell_env_string
  
  =back
  
  Returns a string to set up the C<local::lib>, meant to be run by a shell.
  
  =head2 build_environment_vars
  
  =over 4
  
  =item Arguments: None
  
  =item Return value: %environment_vars
  
  =back
  
  Returns a hash with the variables listed above, properly set to use the
  given path as the base directory.
  
  =head2 setup_env_hash
  
  =over 4
  
  =item Arguments: None
  
  =item Return value: None
  
  =back
  
  Constructs the C<%ENV> keys for the given path, by calling
  L</build_environment_vars>.
  
  =head2 setup_local_lib
  
  Constructs the C<%ENV> hash using L</setup_env_hash>, and set up C<@INC>.
  
  =head1 A WARNING ABOUT UNINST=1
  
  Be careful about using local::lib in combination with "make install UNINST=1".
  The idea of this feature is that will uninstall an old version of a module
  before installing a new one. However it lacks a safety check that the old
  version and the new version will go in the same directory. Used in combination
  with local::lib, you can potentially delete a globally accessible version of a
  module while installing the new version in a local place. Only combine "make
  install UNINST=1" and local::lib if you understand these possible consequences.
  
  =head1 LIMITATIONS
  
  =over 4
  
  =item * Directory names with spaces in them are not well supported by the perl
  toolchain and the programs it uses.  Pure-perl distributions should support
  spaces, but problems are more likely with dists that require compilation. A
  workaround you can do is moving your local::lib to a directory with spaces
  B<after> you installed all modules inside your local::lib bootstrap. But be
  aware that you can't update or install CPAN modules after the move.
  
  =item * Rather basic shell detection. Right now anything with csh in its name is
  assumed to be a C shell or something compatible, and everything else is assumed
  to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is
  not set, a Bourne-compatible shell is assumed.
  
  =item * Kills any existing PERL_MM_OPT or PERL_MB_OPT.
  
  =item * Should probably auto-fixup CPAN config if not already done.
  
  =item * On VMS and MacOS Classic (pre-OS X), local::lib loads L<File::Spec>.
  This means any L<File::Spec> version installed in the local::lib will be
  ignored by scripts using local::lib.  A workaround for this is using
  C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly.
  
  =item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option.
  C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and
  sane behavior.  If something attempts to use the C<PREFIX> option when running
  a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two
  options conflict.  This can be worked around by temporarily unsetting the
  C<PERL_MM_OPT> environment variable.
  
  =item * Conflicts with L<Module::Build>'s C<--prefix> option.  Similar to the
  previous limitation, but any C<--prefix> option specified will be ignored.
  This can be worked around by temporarily unsetting the C<PERL_MB_OPT>
  environment variable.
  
  =back
  
  Patches very much welcome for any of the above.
  
  =over 4
  
  =item * On Win32 systems, does not have a way to write the created environment
  variables to the registry, so that they can persist through a reboot.
  
  =back
  
  =head1 TROUBLESHOOTING
  
  If you've configured local::lib to install CPAN modules somewhere in to your
  home directory, and at some point later you try to install a module with C<cpan
  -i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
  permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
  /usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an
  error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then
  you've somehow lost your updated ExtUtils::MakeMaker module.
  
  To remedy this situation, rerun the bootstrapping procedure documented above.
  
  Then, run C<rm -r ~/.cpan/build/Foo-Bar*>
  
  Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
  
  =head1 ENVIRONMENT
  
  =over 4
  
  =item SHELL
  
  =item COMSPEC
  
  local::lib looks at the user's C<SHELL> environment variable when printing out
  commands to add to the shell configuration file.
  
  On Win32 systems, C<COMSPEC> is also examined.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html>
  
  =back
  
  =head1 SUPPORT
  
  IRC:
  
      Join #toolchain on irc.perl.org.
  
  =head1 AUTHOR
  
  Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
  
  auto_install fixes kindly sponsored by http://www.takkle.com/
  
  =head1 CONTRIBUTORS
  
  Patches to correctly output commands for csh style shells, as well as some
  documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>.
  
  Doc patches for a custom local::lib directory, more cleanups in the english
  documentation and a L<german documentation|POD2::DE::local::lib> contributed by
  Torsten Raudssus <torsten@raudssus.de>.
  
  Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring
  things will install properly, submitted a fix for the bug causing problems with
  writing Makefiles during bootstrapping, contributed an example program, and
  submitted yet another fix to ensure that local::lib can install and bootstrap
  properly. Many, many thanks!
  
  pattern of Freenode IRC contributed the beginnings of the Troubleshooting
  section. Many thanks!
  
  Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>.
  
  Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
  by a patch from Marco Emilio Poleggi.
  
  Mark Stosberg <mark@summersault.com> provided the code for the now deleted
  '--self-contained' option.
  
  Documentation patches to make win32 usage clearer by
  David Mertens <dcmertens.perl@gmail.com> (run4flat).
  
  Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc
  patches contributed by Breno G. de Oliveira <garu@cpan.org>.
  
  Improvements to stacking multiple local::lib dirs and removing them from the
  environment later on contributed by Andrew Rodland <arodland@cpan.org>.
  
  Patch for Carp version mismatch contributed by Hakim Cassimally
  <osfameron@cpan.org>.
  
  Rewrite of internals and numerous bug fixes and added features contributed by
  Graham Knop <haarg@haarg.org>.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as
  listed above.
  
  =head1 LICENSE
  
  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
LOCAL_LIB

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]}) {
      my $pos = 0;
      my $last = length $fat;
      return (sub {
        return 0 if $pos == $last;
        my $next = (1 + index $fat, "\n", $pos) || $last;
        $_ .= substr $fat, $pos, $next - $pos;
        $pos = $next;
        return 1;
      });
    }
  };
}

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/perl
use strict;
use App::perlbrew;

my $app = App::perlbrew->new(@ARGV);
$app->run();

__END__

=head1 NAME

perlbrew - Perl environment manager.

=head1 SYNOPSIS

perlbrew command syntax:

    perlbrew <command> [options] [arguments]

Commands:

    init           Initialize perlbrew environment.
    info           Show useful information about the perlbrew installation

    install        Install perl
    uninstall      Uninstall the given installation
    available      List perls available to install
    lib            Manage local::lib directories.
    alias          Give perl installations a new name
    upgrade-perl   Upgrade the current perl

    list           List perl installations
    use            Use the specified perl in current shell
    off            Turn off perlbrew in current shell
    switch         Permanently use the specified perl as default
    switch-off     Permanently turn off perlbrew (revert to system perl)
    exec           Execute programs with specified perl environments.

    list-modules   List installed CPAN modules for the current Perl version in use
    clone-modules  Re-installs all CPAN modules from one installation to another

    self-install       Install perlbrew itself under PERLBREW_ROOT/bin
    self-upgrade       Upgrade perlbrew itself.

    install-patchperl  Install patchperl
    install-cpanm      Install cpanm, a friendly companion.
    install-cpm        Install cpm, a faster but still friendly companion.
    install-multiple   Install multiple versions and flavors of perl

    download       Download the specified perl distribution tarball.
    clean          Purge tarballs and build directories
    version        Display version
    help           Read more detailed instructions

Generic command options:

    -q --quiet     Be quiet on informative output message.
    -v --verbose   Tell me more about it.

See `perlbrew help` for the full documentation of perlbrew, or

See `perlbrew help <command>` for detail description of the command.

=head1 CONFIGURATION

=over 4

=item PERLBREW_ROOT

By default, perlbrew builds and installs perls into
C<$ENV{HOME}/perl5/perlbrew> directory. To use a different directory,
set this environment variable in your C<bashrc> to the directory
in your shell RC before sourcing perlbrew's RC.

It is possible to share one perlbrew root with multiple user account
on the same machine. Therefore people do not have to install the same
version of perl over an over. Let's say C</opt/perl5> is the directory
we want to share. All users should be able append this snippet to their
bashrc to make it effective:

    export PERLBREW_ROOT=/opt/perl5
    source ${PERLBREW_ROOT}/etc/bashrc

After doing so, everyone's PATH should include C</opt/perl5/bin> and
C</opt/perl5/perls/${PERLBREW_PERL}/bin>. Each user can invoke C<perlbrew
switch> and C<perlbrew use> to independently switch to different perl
environment of their choice. However, only the user with write permission to
C<$PERLBREW_ROOT> may install CPAN modules. This is both good and bad depending
on the working convention of your team.

If you wish to install CPAN modules only for yourself, you should use the C<lib>
command to construct a personal local::lib environment. local::lib environments
are personal, and are not shared between different users. For more detail, read
C<perlbrew help lib> and the documentation of L<local::lib>.

If you want even a cooler module isolation and wish to install CPAN modules used
for just one project, you should use L<carton> for this purpose.

It is also possible to set this variable before installing perlbrew
to make perlbrew install itself under the given PERLBREW_ROOT:

    export PERLBREW_ROOT=/opt/perl5
    curl -L https://install.perlbrew.pl | bash

After doing this, the perlbrew executable is installed as C</opt/perl5/bin/perlbrew>

=item PERLBREW_HOME

By default, perlbrew stores per-user setting to C<$ENV{HOME}/.perlbrew>
directory. To use a different directory, set this environment variable
in your shell RC before sourcing perlbrew's RC.

In some cases, say, your home directory is on NFS and shared across multiple
machines, you may wish to have several different perlbrew setting
per-machine. To do so, you can use the C<PERLBREW_HOME> environment variable to
tell perlbrew where to look for the initialization file. Here's a brief bash
snippet for the given scenario.

    if [ "$(hostname)" == "machine-a" ]; then
        export PERLBREW_HOME=~/.perlbrew-a
    elif [ "$(hostname)" == "machine-b" ]; then
        export PERLBREW_HOME=~/.perlbrew-b
    fi

    source ~/perl5/perlbrew/etc/bashrc

=item PERLBREW_CONFIGURE_FLAGS

This environment variable specify the list of command like flags to pass through
to 'sh Configure'. By default it is '-de'.

=item PERLBREW_CPAN_MIRROR

The CPAN mirror url of your choice. By default, "https://cpan.metacpan.org" is used.

=back

=head1 COMMAND: INIT

Usage: perlbrew init

The C<init> command should be manually invoked whenever you (the perlbrew user)
upgrade or reinstall perlbrew.

If the upgrade is done with C<self-upgrade> command, or by running the
one-line installer manually, this command is invoked automatically.

=head1 COMMAND: INFO

=over 4

=item B<info> [module]

Usage: perlbrew info [ <module> ]

Display useful information about the perlbrew installation.

If a module is given the version and location of the module is displayed.

=back

=head1 COMMAND: INSTALL

Usage:

    perlbrew install [options] <perl-release>
    perlbrew install [options] /path/to/perl-5.14.0.tar.gz
    perlbrew install [options] /path/to/perl/git/checkout/dir
    perlbrew install [options] https://example.com/mirror/perl-5.12.3.tar.gz

Build and install the wanted perl. The last argument can be a short string designating a specific version which can be known from the output of C<perlbrew available>, a path to a pre-downloaded tarball, a path to a git-checkout of perl5 repo, or a URL to a tarball.

The format of <perl-release> looks like:

=over 4

=item perl-<version>

=item perl-stable

=item perl-blead

=item <version>

=item stable

=item blead

=back

Version numbers usually look like "5.x.xx", or "perl-5.xx.x-RCx" for
release candidates.

Version "stable" is a special token that means whatever the latest
stable version is at the moment.

Version "blead" is also a special token that means whatever the latest
version in the repository, which is downloaded from this specific URL
regardless of mirror settings:

    https://github.com/Perl/perl5/archive/blead.tar.gz

The specified perl is downloaded from the official CPAN website or from the
mirror site configured before.

Version number alone without the "perl-" prefix means the official
release provided by perl5 porters.

Options for C<install> command:

    -f --force     Force installation
    -j $n          Parallel building and testing. ex. C<perlbrew install -j 5 perl-5.14.2>
    -n --notest    Skip testing

       --switch    Automatically switch to this Perl once successfully
                   installed, as if with `perlbrew switch <version>`

       --as        Install the given version of perl by a name.
                   ex. C<perlbrew install perl-5.6.2 --as legacy-perl>

       --noman     Skip installation of manpages

       --thread    Build perl with usethreads enabled
       --multi     Build perl with usemultiplicity enabled
       --64int     Build perl with use64bitint enabled
       --64all     Build perl with use64bitall enabled
       --ld        Build perl with uselongdouble enabled
       --debug     Build perl with DEBUGGING enabled
       --clang     Build perl using the clang compiler
       --no-patchperl
                   Skip calling patchperl

    -D,-U,-A       Switches passed to perl Configure script.
                   ex. C<perlbrew install perl-5.10.1 -D usemymalloc -U versiononly>

    --destdir $path
                   Install perl as per 'make install DESTDIR=$path'

    --sitecustomize $filename
                   Specify a file to be installed as sitecustomize.pl

    --mirror $URL
        Specify a CPAN-mirror URL. The default value of this is "https://www.cpan.org"

By default, all installations are configured after their name like this:

    sh Configure -de -Dprefix=$PERLBREW_ROOT/perls/<name>

=head1 COMMAND: INSTALL-MULTIPLE

Usage: perlbrew install-multiple [options] <perl-version-1> <perl-version-2> ...

Build and install the given versions of perl.

C<install-multiple> accepts the same set of options as the command
C<install> plus the following ones:

    --both $flavor       Where $flavor is one of C<thread>, C<multi>, C<ld>,
                         C<64int>, C<64all>, C<debug> and C<clang>.

                         For every given perl version, install two
                         flavors, one with the flag C<--$flavor> set
                         and the other with out. C<--both> can be
                         passed multiple times with different values
                         and in that case, all the possible
                         combinations are generated.

    --common-variations  equivalent to C<--both thread --both ld --both 64int>

    --all-variations     generates all the possible flavor combinations

    --append $string     Appends the given string to the generated names

For instance:

    perlbrew install-multiple 5.18.0 blead --both thread --both debug

Installs the following perls:

    perl-blead
    perl-blead-debug
    perl-blead-thread-multi
    perl-blead-thread-multi-debug
    perl-5.18.0
    perl-5.18.0-debug
    perl-5.18.0-thread-multi
    perl-5.18.0-thread-multi-debug

(note that the C<multi> flavor is selected automatically because
C<thread> requires it)

Another example using custom compilation flags:

    perlbrew install-multiple 5.18.0 --both thread -Doptimize='-O3' --append='-O3'


=head1 COMMAND: UNINSTALL

Usage: perlbrew uninstall <name>

Uninstalls the given perl installation. The name is the installation name as in
the output of `perlbrew list`. This effectively deletes the specified perl installation,
and all libs associated with it.

=head1 COMMAND: USE

Usage: perlbrew B<use> [perl-<version> | <version> | <name>]

Use the given version perl in current shell. This will not effect newly opened
shells.

Without a parameter, shows the version of perl currently in use.

=head1 COMMAND: SWITCH

Usage: perlbrew switch [ <name> ]

Switch to the given version, and makes it the default for this and all
future terminal sessions.

Without a parameter, shows the version of perl currently selected.

=head1 COMMAND: LIST

Usage: perlbrew list

List all perl installations inside perlbrew root specified by C<$PERLBREW_ROOT>
environment variable. By default, the value is C<~/perl5/perlbrew>.

If there are libs associated to some perl installations, they will be included
as part of the name. The output items in this list can be the argument in
various other commands.

=head1 COMMAND: AVAILABLE

Usage: perlbrew available [--all]

List the recently available versions of perl on CPAN.

By default, the latest sub-version of each stable versions are listed.

To get a list of all perls ever released, inculding development and RC versions, run the command with C<--all> option.

=head1 COMMAND: OFF

Usage: perlbrew off

Temporarily disable perlbrew in the current shell. Effectively re-enables the
default system Perl, whatever that is.

This command works only if you add the statement of `source $PERLBREW_ROOT/etc/bashrc`
in your shell initialization (bashrc / zshrc).

=head1 COMMAND: SWITCH-OFF

Usage: perlbrew switch-off

Permananently disable perlbrew. Use C<switch> command to re-enable it. Invoke
C<use> command to enable it only in the current shell.

Re-enables the default system Perl, whatever that is.

=head1 COMMAND: ALIAS

Usage: perlbrew alias [-f] create <name> <alias>

    Create an alias for the installation named <name>.

Usage: perlbrew alias [-f] rename <old_alias> <new_alias>

    Rename the alias to a new name.

Usage: perlbrew alias delete <alias>

    Delete the given alias.

=head1 COMMAND: EXEC

Usage: perlbrew exec [options] <command> <args...>

Options for C<exec> command:

    --with perl-version,... - only use these versions
    --min n.nnnnn           - minimum perl version
                              (format is the same as in 'use 5.012')
    --max n.nnnnn           - maximum perl version
    --halt-on-error         - stop on first nonzero exit status

Execute command for each perl installations, one by one.

For example, run a Hello program:

    perlbrew exec perl -e 'print "Hello from $]\n"'

The output looks like this:

    perl-5.12.2
    ==========
    Hello word from perl-5.012002

    perl-5.13.10
    ==========
    Hello word from perl-5.013010

    perl-5.14.0
    ==========
    Hello word from perl-5.014000

Notice that the command is not executed in parallel.

When C<--with> argument is provided, the command will be only executed with the
specified perl installations. The following command install Moose module into
perl-5.12, regardless the current perl:

    perlbrew exec --with perl-5.12 cpanm Moose

Multiple installation names can be provided:

    perlbrew exec --with perl-5.12,perl-5.12-debug,perl-5.14.2 cpanm Moo

They are split by either spaces or commas. When spaces are used, it is required
to quote the whole specification as one argument, but then commas can be used in
the installation names:

    perlbrew exec --with '5.12 5.12,debug 5.14.2@nobita @shizuka' cpanm Moo

As demonstrated above, "perl-" prefix can be omitted, and lib names can be
specified too. Lib names can appear without a perl installation name, in such
cases it is assumed to be "current perl".

At the moment, any specified names that fails to be resolved as a real
installation names are silently ignored in the output. Also, the command exit
status are not populated back.

=head1 COMMAND: ENV

Usage: perlbrew env [ <name> ]

Low-level command. Invoke this command to see the list of environment
variables that are set by C<perlbrew> itself for shell integration.

The output is something similar to this (if your shell is bash/zsh):

    export PERLBREW_ROOT=/Users/gugod/perl5/perlbrew
    export PERLBREW_VERSION=0.31
    export PERLBREW_PATH=/Users/gugod/perl5/perlbrew/bin:/Users/gugod/perl5/perlbrew/perls/current/bin
    export PERLBREW_PERL=perl-5.14.1

tcsh / csh users should see 'setenv' statements instead of `export`.

=head1 COMMAND: SYMLINK-EXECUTABLES

Usage: perlbrew symlink-executables [ <name> ]

Low-level command. This command is used to create the C<perl> executable
symbolic link to, say, C<perl5.13.6>. This is only required for
development version of perls.

You don't need to do this unless you have been using old perlbrew to install
perls, and you find yourself confused because the perl that you just installed
appears to be missing after invoking `use` or `switch`. perlbrew changes its
installation layout since version 0.11, which generates symlinks to executables
in a better way.

If you just upgraded perlbrew (from 0.11 or earlier versions) and C<perlbrew
switch> failed to work after you switch to a development release of perl, say,
perl-5.13.6, run this command:

    perlbrew symlink-executables perl-5.13.6

This essentially creates this symlink:

   ${PERLBREW_ROOT}/perls/perl-5.13.6/bin/perl
   -> ${PERLBREW_ROOT}/perls/perl-5.13.6/bin/perl5.13.6

Newly installed perls, whether they are development versions or not, does not
need manually treatment with this command.

=head1 COMMAND: INSTALL-CPANM

Usage: perlbrew install-cpanm

Install the C<cpanm> standalone executable in C<$PERLBREW_ROOT/bin>.

For more rationale about the existence of this command, read
<https://perlbrew.pl/Perlbrew-and-Friends.html>

Usage: perlbrew install-cpm

Install the C<cpm> standalone executable in C<$PERLBREW_ROOT/bin>.

=head1 COMMAND: INSTALL-PATCHPERL

Usage: perlbrew install-patchperl

Install the C<patchperl> standalone executable in C<$PERLBREW_ROOT/bin>.  This
is automatically invoked if your perlbrew installation is done with the
installer, but not with cpan.

For more rationale about the existence of this command, read
<https://perlbrew.pl/Perlbrew-and-Friends.html>

=head1 COMMAND: SELF-UPGRADE

Usage: perlbrew self-upgrade

This command upgrades Perlbrew to its latest version.

=head1 COMMAND: SELF-INSTALL

Usage: perlbrew self-install

NOTICE: You should not need to run this command in your daily routine.

This command installs perlbrew itself to C<$PERLBREW_ROOT/bin>. It is intended to
be used by the perlbrew installer. However, you could manually do the following
to re-install only the C<perlbrew> executable:

    curl https://raw.githubusercontent.com/gugod/App-perlbrew/master/perlbrew -o perlbrew
    perl ./perlbrew self-install

It is slightly different from running the perlbrew installer because
C<patchperl> is not installed in this case.

=head1 COMMAND: CLEAN

Usage: perlbrew clean

Removes all previously downloaded Perl tarballs and build directories.

=head1 COMMAND: VERSION

Usage: perlbrew version

Show the version of perlbrew.

=head1 COMMAND: LIB

Usage: perlbrew lib <action> <lib-name>

    perlbrew lib list
    perlbrew lib create <lib-name>
    perlbrew lib delete <lib-name>

The `lib` command is used to manipulate local::lib roots inside perl
installations. Effectively it is similar to `perl
-Mlocal::lib=/path/to/lib-name`, but a little bit more than just that.

A lib name can be a short name, containing alphanumeric, like 'awesome', or a
full name, prefixed by a perl installation name and a '@' sign, for example,
'perl-5.14.2@awesome'.

Here are some a brief examples to invoke the `lib` command:

    # Create lib perl-5.12.3@shizuka
    perlbrew lib create perl-5.12.3@shizuka

    # Create lib perl-5.14.2@nobita and perl-5.14.2@shizuka
    perlbrew use perl-5.14.2
    perlbrew lib create nobita
    perlbrew lib create shizuka

    # See the list of use/switch targets
    perlbrew list

    # Activate a lib in current shell
    perlbrew use perl-5.12.3@shizuka
    perlbrew use perl-5.14.2@nobita
    perlbrew use perl-5.14.2@shizuka

    # Activate a lib as default
    perlbrew switch perl-5.12.3@shizuka
    perlbrew switch perl-5.14.2@nobita
    perlbrew switch perl-5.14.2@shizuka

    # Delete lib perl-5.14.2@nobita and perl-5.14.2@shizuka
    perlbrew use perl-5.14.2
    perlbrew lib delete nobita
    perlbrew lib delete shizuka

    # Delete lib perl-5.12.3@shizuka
    perlbrew lib delete perl-5.12.3@shizuka

Short lib names are local to current perl. A lib name 'nobita' can
refer to 'perl-5.12.3@nobita' or 'perl-5.14.2@nobita', whichever is
activated in the current shell.

When C<use>ing or C<switch>ing to a lib, always provide the long name. A simple
rule: the argument to C<use> or C<switch> command should appear in the output of
C<perlbrew list>.

=head1 COMMAND: UPGRADE-PERL

Usage: perlbrew upgrade-perl

Running this command upgrades the currently activated perl to its
latest released brothers. If you have a shell with 5.32.0 activated,
it upgrades it to 5.32.1.

Minor Perl releases (ex. 5.x.*) are binary compatible with one another, so this
command offers you the ability to upgrade older perlbrew environments in place.

=head1 COMMAND: DOWNLOAD

Usage:
    perlbrew download <perl-release>

Examples:
    perlbrew download perl-5.14.2
    perlbrew download perl-5.16.1
    perlbrew download perl-5.17.3

Download the specified version of perl distribution tarball under
the directory C<< $PERLBREW_ROOT/dists/ >>.

The argument C<perl-release> should be one of the items from
C<perlbrew available> command.

=head1 COMMAND: LIST-MODULES

Usage:
    perlbrew list-modules

List all installed cpan modules for the current perl.

This command can be used in conjunction with `perlbrew exec` to migrate
your module installation to different perl. The following command
re-installs all modules under perl-5.16.0:

    perlbrew list-modules | perlbrew exec --with perl-5.16.0 cpanm

Note that this installs the I<latest> versions of the Perl modules on the new perl,
which are not necessarily the I<same> module versions you had installed previously.

=head1 COMMAND: CLONE-MODULES

Usage:

    perlbrew clone-modules [options] <destination>
    perlbrew clone-modules [options] <source> <destination>

Options:

    --notest    Skip all module tests

This command re-installs all CPAN modules found from one installation to another. For example, this lists all modules under '5.26.1' and re-installs them under '5.27.7':

    perlbrew clone-modules 5.26.1 5.27.7

The argument "source" is optional and defaults to the currently activated one. However if none is activated (perlbrew is switched off), it it an error.

Note that this does not guarantee that the versions of modules stay the same in the destination.

=head1 COMMAND: MAKE-SHIM

Usage:

    perlbrew make-shim <program>
    perlbrew make-shim -o <shim-name> <program>
    perlbrew make-shim --output <shim-name> <program>

This commands produce an executable file under current directory named C<program>, or C<shim-name> if given after C<--output> (or C<-o> for short). The output is a shell-wrapper, a shim, of the named program inside current perlbrew environment.

When the shim is executed, the original C<program> is then executed with all relevant environment variable set to the perlbrew environment it is installed in, regardless which perlbrew environment is currently activated. The shim can also be moved to different directories and, such as the conventional C<~/.local/bin>, so it is always available.

For example, you may find C<tldr> from L<App::tldr> a handy tool and decide to install it inside your daily working environment:

    perlbrew use perl-5.36.1
    cpm install -g App::tldr

But when you occasionally have to switch to a different environment, C<PATH> would be tweaked and the command C<tldr> would went missing, and that is the expected outcome:

    perlbrew use perl-5.18.4
    tldr perl  #=> error: command not found

It would be nice if C<tldr> can be made universally available. One way to mitigate such needs is to prepare install the C<tldr> program outside of C<PERLBREW_ROOT>, while still utilize perlbrew environment to run it.

For example, prepare a conventional directory C<~/.local/bin> and put that in C<PATH>, then:

    perlbrew use perl-5.36.1

    cd /tmp
    perlbrew make-shim tldr
    mv /tmp/tldr ~/.local/bin/tldr

This C<~/.local/bin/tldr> is a shell-wrapper of the actual C<tldr> program, and it internally activates the perlbrew environment C<perl-5.36.1>. Running the tldr shim will then always run the actual C<tldr>, no matter which perlbrew environment is activated, or even if perlbrew is turned off. The only requirements is that the perlbrew environment C<perl-5.36.1> and the installation of C<App::tldr> has to remain.

=head1 COMMAND: MAKE-PP

Usage:

    perlbrew make-pp <program>
    perlbrew make-pp -o <name> <program>
    perlbrew make-pp --output <name> <program>

This commands produce an executable file under current directory named C<program>, or C<name> if given after C<--output> (or C<-o> for short). The output is a PAR-packed version of the named program inside current perlbrew environment.

This requires the current perlbrew environment to have L<PAR> and L<PAR::Packer> installed first. Otherwise C<make-pp> bails out. In addition, if current perl is not a perlbrew-managed perl, <make-pp> also bails out.

The produced file is a standalone binary executable containing these content:

    1. The named program
    2. perl runtime
    3. all core perl libs of current perl
    4. the entire site lib
    5. the entire local lib (managed by `perlbrew lib` command), if active.

It is expected that the executable can then be running on a different machine of the same OS and arch.

Noted that this approach is the maximum overkill for packing one program as it'll be definitely packaing a lot more then the exact list of runtime dependencies of the named program. C<make-pp> is meant for a lazy solution for a non-trivial problem of perfectly determing the runtime dependencies of an arbitarary program.

=head1 SEE ALSO

L<App::perlbrew>, L<App::cpanminus>, L<Devel::PatchPerl>

=cut