package App::cpanminus::fatscript;
#
# This is a pre-compiled source code for the cpanm (cpanminus) program.
# For more details about how to install cpanm, go to the following URL:
#
#   https://github.com/miyagawa/cpanminus
#
# Quickstart: Run the following command and it will install itself for
# you. You might want to run it as a root with sudo if you want to install
# to places like /usr/local/bin.
#
#   % curl -L https://cpanmin.us | perl - App::cpanminus
#
# If you don't have curl but wget, replace `curl -L` with `wget -O -`.

# DO NOT EDIT -- this is an auto generated file

# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;

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

$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
  package App::cpanminus;
  our $VERSION = "1.7904";
  
  =encoding utf8
  
  =head1 NAME
  
  App::cpanminus - get, unpack, build and install modules from CPAN
  
  =head1 SYNOPSIS
  
      cpanm Module
  
  Run C<cpanm -h> or C<perldoc cpanm> for more options.
  
  =head1 DESCRIPTION
  
  cpanminus is a script to get, unpack, build and install modules from
  CPAN and does nothing else.
  
  It's dependency free (can bootstrap itself), requires zero
  configuration, and stands alone. When running, it requires only 10MB
  of RAM.
  
  =head1 INSTALLATION
  
  There are several ways to install cpanminus to your system.
  
  =head2 Package management system
  
  There are Debian packages, RPMs, FreeBSD ports, and packages for other
  operation systems available. If you want to use the package management system,
  search for cpanminus and use the appropriate command to install. This makes it
  easy to install C<cpanm> to your system without thinking about where to
  install, and later upgrade.
  
  =head2 Installing to system perl
  
  You can also use the latest cpanminus to install cpanminus itself:
  
      curl -L https://cpanmin.us | perl - --sudo App::cpanminus
  
  This will install C<cpanm> to your bin directory like
  C</usr/local/bin> and you'll need the C<--sudo> option to write to
  the directory, unless you configured C<INSTALL_BASE> with L<local::lib>.
  
  =head2 Installing to local perl (perlbrew, plenv etc.)
  
  If you have perl in your home directory, which is the case if you use
  tools like L<perlbrew> or plenv, you don't need the C<--sudo> option, since
  you're most likely to have a write permission to the perl's library
  path. You can just do:
  
      curl -L https://cpanmin.us | perl - App::cpanminus
  
  to install the C<cpanm> executable to the perl's bin path, like
  C<~/perl5/perlbrew/bin/cpanm>.
  
  =head2 Downloading the standalone executable
  
  You can also copy the standalone executable to whatever location you'd like.
  
      cd ~/bin
      curl -L https://cpanmin.us/ -o cpanm
      chmod +x cpanm
  
  This just works, but be sure to grab the new version manually when you
  upgrade because C<--self-upgrade> might not work with this installation setup.
  
  =head2 Troubleshoot: HTTPS warnings
  
  When you run C<curl> commands above, you may encounter SSL handshake
  errors or certification warnings. This is due to your HTTP client
  (curl) being old, or SSL certificates installed on your system needs
  to be updated.
  
  You're recommended to update the software or system if you can. If
  that is impossible or difficult, use the C<-k> option with curl.
  
  =head1 DEPENDENCIES
  
  perl 5.8.1 or later.
  
  =over 4
  
  =item *
  
  'tar' executable (bsdtar or GNU tar version 1.22 are recommended) or Archive::Tar to unpack files.
  
  =item *
  
  C compiler, if you want to build XS modules.
  
  =item *
  
  make
  
  =item *
  
  Module::Build (core in 5.10)
  
  =back
  
  =head1 QUESTIONS
  
  =head2 How does cpanm get/parse/update the CPAN index?
  
  It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>.
  The site is updated at least every hour to reflect the latest changes
  from fast syncing mirrors. The script then also falls back to query the
  module at L<http://metacpan.org/> using its search API.
  
  Upon calling these API hosts, cpanm (1.6004 or later) will send the
  local perl versions to the server in User-Agent string by default. You
  can turn it off with C<--no-report-perl-version> option. Read more
  about the option with L<cpanm>, and read more about the privacy policy
  about this data collection at L<http://cpanmetadb.plackperl.org/#privacy>
  
  Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up
  periodically.  You can configure the location of this with the
  C<PERL_CPANM_HOME> environment variable.
  
  =head2 Where does this install modules to? Do I need root access?
  
  It installs to wherever ExtUtils::MakeMaker and Module::Build are
  configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>).
  
  By default, it installs to the site_perl directory that belongs to
  your perl. You can see the locations for that by running C<perl -V>
  and it will be likely something under C</opt/local/perl/...> if you're
  using system perl, or under your home directory if you have built perl
  yourself using perlbrew or plenv.
  
  If you've already configured local::lib on your shell, cpanm respects
  that settings and modules will be installed to your local perl5
  directory.
  
  At a boot time, cpanminus checks whether you have already configured
  local::lib, or have a permission to install modules to the site_perl
  directory.  If neither, i.e. you're using system perl and do not run
  cpanm as a root, it automatically sets up local::lib compatible
  installation path in a C<perl5> directory under your home
  directory.
  
  To avoid this, run C<cpanm> either as a root user, with C<--sudo>
  option, or with C<--local-lib> option.
  
  =head2 cpanminus can't install the module XYZ. Is it a bug?
  
  It is more likely a problem with the distribution itself. cpanminus
  doesn't support or may have issues with distributions such as follows:
  
  =over 4
  
  =item *
  
  Tests that require input from STDIN.
  
  =item *
  
  Build.PL or Makefile.PL that prompts for input even when
  C<PERL_MM_USE_DEFAULT> is enabled.
  
  =item *
  
  Modules that have invalid numeric values as VERSION (such as C<1.1a>)
  
  =back
  
  These failures can be reported back to the author of the module so
  that they can fix it accordingly, rather than to cpanminus.
  
  =head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>?
  
  Most likely not. Here are the things that cpanm doesn't do by
  itself.
  
  If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone
  tools that are mentioned.
  
  =over 4
  
  =item *
  
  CPAN testers reporting. See L<App::cpanminus::reporter>
  
  =item *
  
  Building RPM packages from CPAN modules
  
  =item *
  
  Listing the outdated modules that needs upgrading. See L<App::cpanoutdated>
  
  =item *
  
  Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges>
  
  =item *
  
  Patching CPAN modules with distroprefs.
  
  =back
  
  See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :)
  
  =head1 COPYRIGHT
  
  Copyright 2010- Tatsuhiko Miyagawa
  
  The standalone executable contains the following modules embedded.
  
  =over 4
  
  =item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr
  
  =item L<local::lib> Copyright 2007-2009 Matt S Trout
  
  =item L<HTTP::Tiny> Copyright 2011 Christian Hansen
  
  =item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout
  
  =item L<version> Copyright 2004-2010 John Peacock
  
  =item L<JSON::PP> Copyright 2007-2011 by Makamaka Hannyaharamitu
  
  =item L<CPAN::Meta>, L<CPAN::Meta::Requirements> Copyright (c) 2010 by David Golden and Ricardo Signes
  
  =item L<CPAN::Meta::YAML> Copyright 2010 Adam Kennedy
  
  =item L<CPAN::Meta::Check> Copyright (c) 2012 by Leon Timmermans
  
  =item L<File::pushd> Copyright 2012 David Golden
  
  =item L<parent> Copyright (c) 2007-10 Max Maischein
  
  =item L<Parse::PMFile> Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki
  
  =item L<String::ShellQuote> by Roderick Schertler
  
  
  =back
  
  =head1 LICENSE
  
  This software is licensed under the same terms as Perl.
  
  =head1 CREDITS
  
  =head2 CONTRIBUTORS
  
  Patches and code improvements were contributed by:
  
  Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian
  Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky,
  horus and Ingy dot Net.
  
  =head2 ACKNOWLEDGEMENTS
  
  Bug reports, suggestions and feedbacks were sent by, or general
  acknowledgement goes to:
  
  Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris
  Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse
  Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren,
  Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar
  Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron.
  
  =head1 COMMUNITY
  
  =over 4
  
  =item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
  
  =item L<irc://irc.perl.org/#cpanm> - discussions about cpanm and its related tools
  
  =back
  
  =head1 NO WARRANTY
  
  This software is provided "as-is," without any express or implied
  warranty. In no event shall the author be held liable for any damages
  arising from the use of the software.
  
  =head1 SEE ALSO
  
  L<CPAN> L<CPANPLUS> L<pip>
  
  =cut
  
  1;
APP_CPANMINUS

$fatpacked{"CPAN/Common/Index.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX';
  use 5.008001;
  use strict;
  use warnings;
  
  package CPAN::Common::Index;
  # ABSTRACT: Common library for searching CPAN modules, authors and distributions
  
  our $VERSION = '0.010';
  
  use Carp ();
  
  use Class::Tiny;
  
  #--------------------------------------------------------------------------#
  # Document abstract methods
  #--------------------------------------------------------------------------#
  
  #pod =method search_packages (ABSTRACT)
  #pod
  #pod     $result = $index->search_packages( { package => "Moose" });
  #pod     @result = $index->search_packages( \%advanced_query );
  #pod
  #pod Searches the index for a package such as listed in the CPAN
  #pod F<02packages.details.txt> file.  The query must be provided as a hash
  #pod reference.  Valid keys are
  #pod
  #pod =for :list
  #pod * package -- a string, regular expression or code reference
  #pod * version -- a version number or code reference
  #pod * dist -- a string, regular expression or code reference
  #pod
  #pod If the query term is a string or version number, the query will be for an exact
  #pod match.  If a code reference, the code will be called with the value of the
  #pod field for each potential match.  It should return true if it matches.
  #pod
  #pod Not all backends will implement support for all fields or all types of queries.
  #pod If it does not implement either, it should "decline" the query with an empty
  #pod return.
  #pod
  #pod The return should be context aware, returning either a
  #pod single result or a list of results.
  #pod
  #pod The result must be formed as follows:
  #pod
  #pod     {
  #pod       package => 'MOOSE',
  #pod       version => '2.0802',
  #pod       uri     => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
  #pod     }
  #pod
  #pod The C<uri> field should be a valid URI.  It may be a L<URI::cpan> or any other
  #pod URI.  (It is up to a client to do something useful with any given URI scheme.)
  #pod
  #pod =method search_authors (ABSTRACT)
  #pod
  #pod     $result = $index->search_authors( { id => "DAGOLDEN" });
  #pod     @result = $index->search_authors( \%advanced_query );
  #pod
  #pod Searches the index for author data such as from the CPAN F<01mailrc.txt> file.
  #pod The query must be provided as a hash reference.  Valid keys are
  #pod
  #pod =for :list
  #pod * id -- a string, regular expression or code reference
  #pod * fullname -- a string, regular expression or code reference
  #pod * email -- a string, regular expression or code reference
  #pod
  #pod If the query term is a string, the query will be for an exact match.  If a code
  #pod reference, the code will be called with the value of the field for each
  #pod potential match.  It should return true if it matches.
  #pod
  #pod Not all backends will implement support for all fields or all types of queries.
  #pod If it does not implement either, it should "decline" the query with an empty
  #pod return.
  #pod
  #pod The return should be context aware, returning either a single result or a list
  #pod of results.
  #pod
  #pod The result must be formed as follows:
  #pod
  #pod     {
  #pod         id       => 'DAGOLDEN',
  #pod         fullname => 'David Golden',
  #pod         email    => 'dagolden@cpan.org',
  #pod     }
  #pod
  #pod The C<email> field may not reflect an actual email address.  The 01mailrc file
  #pod on CPAN often shows "CENSORED" when email addresses are concealed.
  #pod
  #pod =cut
  
  #--------------------------------------------------------------------------#
  # stub methods
  #--------------------------------------------------------------------------#
  
  #pod =method index_age
  #pod
  #pod     $epoch = $index->index_age;
  #pod
  #pod Returns the modification time of the index in epoch seconds.  This may not make sense
  #pod for some backends.  By default it returns the current time.
  #pod
  #pod =cut
  
  sub index_age { time }
  
  #pod =method refresh_index
  #pod
  #pod     $index->refresh_index;
  #pod
  #pod This ensures the index source is up to date.  For example, a remote
  #pod mirror file would be re-downloaded.  By default, it does nothing.
  #pod
  #pod =cut
  
  sub refresh_index { 1 }
  
  #pod =method attributes
  #pod
  #pod Return attributes and default values as a hash reference.  By default
  #pod returns an empty hash reference.
  #pod
  #pod =cut
  
  sub attributes { {} }
  
  #pod =method validate_attributes
  #pod
  #pod     $self->validate_attributes;
  #pod
  #pod This is called by the constructor to validate any arguments.  Subclasses
  #pod should override the default one to perform validation.  It should not be
  #pod called by application code.  By default, it does nothing.
  #pod
  #pod =cut
  
  sub validate_attributes { 1 }
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Common::Index - Common library for searching CPAN modules, authors and distributions
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
      use CPAN::Common::Index::Mux::Ordered;
      use Data::Dumper;
  
      $index = CPAN::Common::Index::Mux::Ordered->assemble(
          MetaDB => {},
          Mirror => { mirror => "http://cpan.cpantesters.org" },
      );
  
      $result = $index->search_packages( { package => "Moose" } );
  
      print Dumper($result);
  
      # {
      #   package => 'MOOSE',
      #   version => '2.0802',
      #   uri     => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
      # }
  
  =head1 DESCRIPTION
  
  This module provides a common library for working with a variety of CPAN index
  services.  It is intentionally minimalist, trying to use as few non-core
  modules as possible.
  
  The C<CPAN::Common::Index> module is an abstract base class that defines a
  common API.  Individual backends deliver the API for a particular index.
  
  As shown in the SYNOPSIS, one interesting application is multiplexing -- using
  different index backends, querying each in turn, and returning the first
  result.
  
  =head1 METHODS
  
  =head2 search_packages (ABSTRACT)
  
      $result = $index->search_packages( { package => "Moose" });
      @result = $index->search_packages( \%advanced_query );
  
  Searches the index for a package such as listed in the CPAN
  F<02packages.details.txt> file.  The query must be provided as a hash
  reference.  Valid keys are
  
  =over 4
  
  =item *
  
  package -- a string, regular expression or code reference
  
  =item *
  
  version -- a version number or code reference
  
  =item *
  
  dist -- a string, regular expression or code reference
  
  =back
  
  If the query term is a string or version number, the query will be for an exact
  match.  If a code reference, the code will be called with the value of the
  field for each potential match.  It should return true if it matches.
  
  Not all backends will implement support for all fields or all types of queries.
  If it does not implement either, it should "decline" the query with an empty
  return.
  
  The return should be context aware, returning either a
  single result or a list of results.
  
  The result must be formed as follows:
  
      {
        package => 'MOOSE',
        version => '2.0802',
        uri     => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
      }
  
  The C<uri> field should be a valid URI.  It may be a L<URI::cpan> or any other
  URI.  (It is up to a client to do something useful with any given URI scheme.)
  
  =head2 search_authors (ABSTRACT)
  
      $result = $index->search_authors( { id => "DAGOLDEN" });
      @result = $index->search_authors( \%advanced_query );
  
  Searches the index for author data such as from the CPAN F<01mailrc.txt> file.
  The query must be provided as a hash reference.  Valid keys are
  
  =over 4
  
  =item *
  
  id -- a string, regular expression or code reference
  
  =item *
  
  fullname -- a string, regular expression or code reference
  
  =item *
  
  email -- a string, regular expression or code reference
  
  =back
  
  If the query term is a string, the query will be for an exact match.  If a code
  reference, the code will be called with the value of the field for each
  potential match.  It should return true if it matches.
  
  Not all backends will implement support for all fields or all types of queries.
  If it does not implement either, it should "decline" the query with an empty
  return.
  
  The return should be context aware, returning either a single result or a list
  of results.
  
  The result must be formed as follows:
  
      {
          id       => 'DAGOLDEN',
          fullname => 'David Golden',
          email    => 'dagolden@cpan.org',
      }
  
  The C<email> field may not reflect an actual email address.  The 01mailrc file
  on CPAN often shows "CENSORED" when email addresses are concealed.
  
  =head2 index_age
  
      $epoch = $index->index_age;
  
  Returns the modification time of the index in epoch seconds.  This may not make sense
  for some backends.  By default it returns the current time.
  
  =head2 refresh_index
  
      $index->refresh_index;
  
  This ensures the index source is up to date.  For example, a remote
  mirror file would be re-downloaded.  By default, it does nothing.
  
  =head2 attributes
  
  Return attributes and default values as a hash reference.  By default
  returns an empty hash reference.
  
  =head2 validate_attributes
  
      $self->validate_attributes;
  
  This is called by the constructor to validate any arguments.  Subclasses
  should override the default one to perform validation.  It should not be
  called by application code.  By default, it does nothing.
  
  =for Pod::Coverage method_names_here
  
  =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/Perl-Toolchain-Gang/CPAN-Common-Index/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/Perl-Toolchain-Gang/CPAN-Common-Index>
  
    git clone https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =for stopwords David Golden Helmut Wollmersdorfer Kenichi Ishigaki Shoichi Kaji Tatsuhiko Miyagawa
  
  =over 4
  
  =item *
  
  David Golden <xdg@xdg.me>
  
  =item *
  
  Helmut Wollmersdorfer <helmut@wollmersdorfer.at>
  
  =item *
  
  Kenichi Ishigaki <ishigaki@cpan.org>
  
  =item *
  
  Shoichi Kaji <skaji@cpan.org>
  
  =item *
  
  Tatsuhiko Miyagawa <miyagawa@bulknews.net>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
CPAN_COMMON_INDEX

$fatpacked{"CPAN/Common/Index/LocalPackage.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_LOCALPACKAGE';
  use 5.008001;
  use strict;
  use warnings;
  
  package CPAN::Common::Index::LocalPackage;
  # ABSTRACT: Search index via custom local CPAN package flatfile
  
  our $VERSION = '0.010';
  
  use parent 'CPAN::Common::Index::Mirror';
  
  use Class::Tiny qw/source/;
  
  use Carp;
  use File::Basename ();
  use File::Copy ();
  use File::Spec;
  use File::stat ();
  
  #pod =attr source (REQUIRED)
  #pod
  #pod Path to a local file in the form of 02packages.details.txt.  It may
  #pod be compressed with a ".gz" suffix or it may be uncompressed.
  #pod
  #pod =attr cache
  #pod
  #pod Path to a local directory to store a (possibly uncompressed) copy
  #pod of the source index.  Defaults to a temporary directory if not
  #pod specified.
  #pod
  #pod =cut
  
  sub BUILD {
      my $self = shift;
  
      my $file = $self->source;
      if ( !defined $file ) {
          Carp::croak("'source' parameter must be provided");
      }
      elsif ( !-f $file ) {
          Carp::croak("index file '$file' does not exist");
      }
  
      return;
  }
  
  sub cached_package {
      my ($self) = @_;
      my $package = File::Spec->catfile(
          $self->cache, File::Basename::basename($self->source)
      );
      $package =~ s/\.gz$//;
      $self->refresh_index unless -r $package;
      return $package;
  }
  
  sub refresh_index {
      my ($self) = @_;
      my $source = $self->source;
      my $basename = File::Basename::basename($source);
      if ( $source =~ /\.gz$/ ) {
          Carp::croak "can't load gz source files without IO::Uncompress::Gunzip\n"
            unless $CPAN::Common::Index::Mirror::HAS_IO_UNCOMPRESS_GUNZIP;
          ( my $uncompressed = $basename ) =~ s/\.gz$//;
          $uncompressed = File::Spec->catfile( $self->cache, $uncompressed );
          if ( !-f $uncompressed
                or File::stat::stat($source)->mtime > File::stat::stat($uncompressed)->mtime ) {
              no warnings 'once';
              IO::Uncompress::Gunzip::gunzip( map { "$_" } $source, $uncompressed )
                or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
          }
      }
      else {
          my $dest = File::Spec->catfile( $self->cache, $basename );
          File::Copy::copy($source, $dest)
            if !-e $dest || File::stat::stat($source)->mtime > File::stat::stat($dest)->mtime;
      }
      return 1;
  }
  
  sub search_authors { return }; # this package handles packages only
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Common::Index::LocalPackage - Search index via custom local CPAN package flatfile
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
    use CPAN::Common::Index::LocalPackage;
  
    $index = CPAN::Common::Index::LocalPackage->new(
      { source => "mypackages.details.txt" }
    );
  
  =head1 DESCRIPTION
  
  This module implements a CPAN::Common::Index that searches for packages in a local
  index file in the same form as the CPAN 02packages.details.txt file.
  
  There is no support for searching on authors.
  
  =head1 ATTRIBUTES
  
  =head2 source (REQUIRED)
  
  Path to a local file in the form of 02packages.details.txt.  It may
  be compressed with a ".gz" suffix or it may be uncompressed.
  
  =head2 cache
  
  Path to a local directory to store a (possibly uncompressed) copy
  of the source index.  Defaults to a temporary directory if not
  specified.
  
  =for Pod::Coverage attributes validate_attributes search_packages search_authors
  cached_package BUILD
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
CPAN_COMMON_INDEX_LOCALPACKAGE

$fatpacked{"CPAN/Common/Index/MetaDB.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_METADB';
  use 5.008001;
  use strict;
  use warnings;
  
  package CPAN::Common::Index::MetaDB;
  # ABSTRACT: Search index via CPAN MetaDB
  
  our $VERSION = '0.010';
  
  use parent 'CPAN::Common::Index';
  
  use Class::Tiny qw/uri/;
  
  use Carp;
  use CPAN::Meta::YAML;
  use HTTP::Tiny;
  
  #pod =attr uri
  #pod
  #pod A URI for the endpoint of a CPAN MetaDB server. The
  #pod default is L<http://cpanmetadb.plackperl.org/v1.0/>.
  #pod
  #pod =cut
  
  sub BUILD {
      my $self = shift;
      my $uri  = $self->uri;
      $uri = "http://cpanmetadb.plackperl.org/v1.0/"
        unless defined $uri;
      # ensure URI ends in '/'
      $uri =~ s{/?$}{/};
      $self->uri($uri);
      return;
  }
  
  sub search_packages {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_packages must be hash reference")
        unless ref $args eq 'HASH';
  
      # only support direct package query
      return
        unless keys %$args == 1 && exists $args->{package} && ref $args->{package} eq '';
  
      my $mod = $args->{package};
      my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
      return unless $res->{success};
  
      if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
          my $meta = $yaml->[0];
          if ( $meta && $meta->{distfile} ) {
              my $file = $meta->{distfile};
              $file =~ s{^./../}{}; # strip leading
              return {
                  package => $mod,
                  version => $meta->{version},
                  uri     => "cpan:///distfile/$file",
              };
          }
      }
  
      return;
  }
  
  sub index_age { return time };    # pretend always current
  
  sub search_authors { return };    # not supported
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Common::Index::MetaDB - Search index via CPAN MetaDB
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
    use CPAN::Common::Index::MetaDB;
  
    $index = CPAN::Common::Index::MetaDB->new;
  
  =head1 DESCRIPTION
  
  This module implements a CPAN::Common::Index that searches for packages against
  the same CPAN MetaDB API used by L<cpanminus>.
  
  There is no support for advanced package queries or searching authors.  It just
  takes a package name and returns the corresponding version and distribution.
  
  =head1 ATTRIBUTES
  
  =head2 uri
  
  A URI for the endpoint of a CPAN MetaDB server. The
  default is L<http://cpanmetadb.plackperl.org/v1.0/>.
  
  =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
CPAN_COMMON_INDEX_METADB

$fatpacked{"CPAN/Common/Index/Mirror.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_MIRROR';
  use 5.008001;
  use strict;
  use warnings;
  
  package CPAN::Common::Index::Mirror;
  # ABSTRACT: Search index via CPAN mirror flatfiles
  
  our $VERSION = '0.010';
  
  use parent 'CPAN::Common::Index';
  
  use Class::Tiny qw/cache mirror/;
  
  use Carp;
  use CPAN::DistnameInfo;
  use File::Basename ();
  use File::Fetch;
  use File::Temp 0.19; # newdir
  use Search::Dict 1.07;
  use Tie::Handle::SkipHeader;
  use URI;
  
  our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
  
  #pod =attr mirror
  #pod
  #pod URI to a CPAN mirror.  Defaults to C<http://www.cpan.org/>.
  #pod
  #pod =attr cache
  #pod
  #pod Path to a local directory to store copies of the source indices.  Defaults to a
  #pod temporary directory if not specified.
  #pod
  #pod =cut
  
  sub BUILD {
      my $self = shift;
  
      # cache directory needs to exist
      my $cache = $self->cache;
      $cache = File::Temp->newdir
        unless defined $cache;
      if ( !-d $cache ) {
          Carp::croak("Cache directory '$cache' does not exist");
      }
      $self->cache($cache);
  
      # ensure mirror URL ends in '/'
      my $mirror = $self->mirror;
      $mirror = "http://www.cpan.org/"
        unless defined $mirror;
      $mirror =~ s{/?$}{/};
      $self->mirror($mirror);
  
      return;
  }
  
  my %INDICES = (
      mailrc   => 'authors/01mailrc.txt.gz',
      packages => 'modules/02packages.details.txt.gz',
  );
  
  # XXX refactor out from subs below
  my %TEST_GENERATORS = (
      regexp_nocase => sub {
          my $arg = shift;
          my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/i;
          return sub { $_[0] =~ $re };
      },
      regexp => sub {
          my $arg = shift;
          my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/;
          return sub { $_[0] =~ $re };
      },
      version => sub {
          my $arg = shift;
          my $v   = version->parse($arg);
          return sub {
              eval { version->parse( $_[0] ) == $v };
          };
      },
  );
  
  my %QUERY_TYPES = (
      # package search
      package => 'regexp',
      version => 'version',
      dist    => 'regexp',
  
      # author search
      id       => 'regexp_nocase', # XXX need to add "alias " first
      fullname => 'regexp_nocase',
      email    => 'regexp_nocase',
  );
  
  sub cached_package {
      my ($self) = @_;
      my $package = File::Spec->catfile( $self->cache,
          File::Basename::basename( $INDICES{packages} ) );
      $package =~ s/\.gz$//;
      $self->refresh_index unless -r $package;
      return $package;
  }
  
  sub cached_mailrc {
      my ($self) = @_;
      my $mailrc =
        File::Spec->catfile( $self->cache, File::Basename::basename( $INDICES{mailrc} ) );
      $mailrc =~ s/\.gz$//;
      $self->refresh_index unless -r $mailrc;
      return $mailrc;
  }
  
  sub refresh_index {
      my ($self) = @_;
      for my $file ( values %INDICES ) {
          my $remote = URI->new_abs( $file, $self->mirror );
          $remote =~ s/\.gz$//
            unless $HAS_IO_UNCOMPRESS_GUNZIP;
          my $ff = File::Fetch->new( uri => $remote );
          my $where = $ff->fetch( to => $self->cache )
            or Carp::croak( $ff->error );
          if ($HAS_IO_UNCOMPRESS_GUNZIP) {
              ( my $uncompressed = $where ) =~ s/\.gz$//;
              no warnings 'once';
              IO::Uncompress::Gunzip::gunzip( $where, $uncompressed )
                or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
          }
      }
      return 1;
  }
  
  # epoch secs
  sub index_age {
      my ($self) = @_;
      my $package = $self->cached_package;
      return ( -r $package ? ( stat($package) )[9] : 0 ); # mtime if readable
  }
  
  sub search_packages {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_packages must be hash reference")
        unless ref $args eq 'HASH';
  
      my $index_path = $self->cached_package;
      die "Can't read $index_path" unless -r $index_path;
  
      my $fh = IO::Handle->new;
      tie *$fh, 'Tie::Handle::SkipHeader', "<", $index_path
        or die "Can't tie $index_path: $!";
  
      # Convert scalars or regexps to subs
      my $rules;
      while ( my ( $k, $v ) = each %$args ) {
          $rules->{$k} = _rulify( $k, $v );
      }
  
      my @found;
      if ( $args->{package} and ref $args->{package} eq '' ) {
          # binary search 02packages on package
          my $pos = look $fh, $args->{package}, { xfrm => \&_xform_package, fold => 1 };
          return if $pos == -1;
          # loop over any case-insensitive matching lines
          LINE: while ( my $line = <$fh> ) {
              last unless $line =~ /\A\Q$args->{package}\E\s+/i;
              push @found, _match_package_line( $line, $rules );
          }
      }
      else {
          # iterate all lines looking for match
          LINE: while ( my $line = <$fh> ) {
              push @found, _match_package_line( $line, $rules );
          }
      }
      return wantarray ? @found : $found[0];
  }
  
  sub search_authors {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_authors must be hash reference")
        unless ref $args eq 'HASH';
  
      my $index_path = $self->cached_mailrc;
      die "Can't read $index_path" unless -r $index_path;
      open my $fh, $index_path or die "Can't open $index_path: $!";
  
      # Convert scalars or regexps to subs
      my $rules;
      while ( my ( $k, $v ) = each %$args ) {
          $rules->{$k} = _rulify( $k, $v );
      }
  
      my @found;
      if ( $args->{id} and ref $args->{id} eq '' ) {
          # binary search mailrec on package
          my $pos = look $fh, $args->{id}, { xfrm => \&_xform_mailrc, fold => 1 };
          return if $pos == -1;
          my $line = <$fh>;
          push @found, _match_mailrc_line( $line, $rules );
      }
      else {
          # iterate all lines looking for match
          LINE: while ( my $line = <$fh> ) {
              push @found, _match_mailrc_line( $line, $rules );
          }
      }
      return wantarray ? @found : $found[0];
  }
  
  sub _rulify {
      my ( $key, $arg ) = @_;
      return $arg if ref($arg) eq 'CODE';
      return $TEST_GENERATORS{ $QUERY_TYPES{$key} }->($arg);
  }
  
  sub _xform_package {
      my @fields = split " ", $_[0], 2;
      return $fields[0];
  }
  
  sub _xform_mailrc {
      my @fields = split " ", $_[0], 3;
      return $fields[1];
  }
  
  sub _match_package_line {
      my ( $line, $rules ) = @_;
      return unless defined $line;
      my ( $mod, $version, $dist, $comment ) = split " ", $line, 4;
      if ( $rules->{package} ) {
          return unless $rules->{package}->($mod);
      }
      if ( $rules->{version} ) {
          return unless $rules->{version}->($version);
      }
      if ( $rules->{dist} ) {
          return unless $rules->{dist}->($dist);
      }
      $dist =~ s{\A./../}{};
      return {
          package => $mod,
          version => $version,
          uri     => "cpan:///distfile/$dist",
      };
  }
  
  sub _match_mailrc_line {
      my ( $line, $rules ) = @_;
      return unless defined $line;
      my ( $id,       $address ) = $line =~ m{\Aalias\s+(\S+)\s+"(.*)"};
      my ( $fullname, $email )   = $address =~ m{([^<]+)<([^>]+)>};
      $fullname =~ s/\s*$//;
      if ( $rules->{id} ) {
          return unless $rules->{id}->($id);
      }
      if ( $rules->{fullname} ) {
          return unless $rules->{fullname}->($fullname);
      }
      if ( $rules->{email} ) {
          return unless $rules->{email}->($email);
      }
      return {
          id       => $id,
          fullname => $fullname,
          email    => $email,
      };
  }
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Common::Index::Mirror - Search index via CPAN mirror flatfiles
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
    use CPAN::Common::Index::Mirror;
  
    # default mirror is http://www.cpan.org/
    $index = CPAN::Common::Index::Mirror->new;
  
    # custom mirror
    $index = CPAN::Common::Index::Mirror->new(
      { mirror => "http://cpan.cpantesters.org" }
    );
  
  =head1 DESCRIPTION
  
  This module implements a CPAN::Common::Index that retrieves and searches
  02packages.details.txt and 01mailrc.txt indices.
  
  The default mirror is L<http://www.cpan.org/>.  This is a globally balanced
  fast mirror and is a great choice if you don't have a local fast mirror.
  
  =head1 ATTRIBUTES
  
  =head2 mirror
  
  URI to a CPAN mirror.  Defaults to C<http://www.cpan.org/>.
  
  =head2 cache
  
  Path to a local directory to store copies of the source indices.  Defaults to a
  temporary directory if not specified.
  
  =for Pod::Coverage attributes validate_attributes search_packages search_authors
  cached_package cached_mailrc BUILD
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
CPAN_COMMON_INDEX_MIRROR

$fatpacked{"CPAN/Common/Index/Mux/Ordered.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_MUX_ORDERED';
  use 5.008001;
  use strict;
  use warnings;
  
  package CPAN::Common::Index::Mux::Ordered;
  # ABSTRACT: Consult indices in order and return the first result
  
  our $VERSION = '0.010';
  
  use parent 'CPAN::Common::Index';
  
  use Class::Tiny qw/resolvers/;
  
  use Module::Load ();
  
  #pod =attr resolvers
  #pod
  #pod     An array reference of CPAN::Common::Index::* objects
  #pod
  #pod =cut
  
  sub BUILD {
      my $self = shift;
  
      my $resolvers = $self->resolvers;
      $resolvers = [] unless defined $resolvers;
      if ( ref $resolvers ne 'ARRAY' ) {
          Carp::croak("The 'resolvers' argument must be an array reference");
      }
      for my $r (@$resolvers) {
          if ( !eval { $r->isa("CPAN::Common::Index") } ) {
              Carp::croak("Resolver '$r' is not a CPAN::Common::Index object");
          }
      }
      $self->resolvers($resolvers);
  
      return;
  }
  
  #pod =method assemble
  #pod
  #pod     $index = CPAN::Common::Index::Mux::Ordered->assemble(
  #pod         MetaDB => {},
  #pod         Mirror => { mirror => "http://www.cpan.org" },
  #pod     );
  #pod
  #pod This class method provides a shorthand for constructing a multiplexer.
  #pod The arguments must be pairs of subclass suffixes and arguments.  For
  #pod example, "MetaDB" means to use "CPAN::Common::Index::MetaDB".  Empty
  #pod arguments must be given as an empty hash reference.
  #pod
  #pod =cut
  
  sub assemble {
      my ( $class, @backends ) = @_;
  
      my @resolvers;
  
      while (@backends) {
          my ( $subclass, $config ) = splice @backends, 0, 2;
          my $full_class = "CPAN::Common::Index::${subclass}";
          eval { Module::Load::load($full_class); 1 }
            or Carp::croak($@);
          my $object = $full_class->new($config);
          push @resolvers, $object;
      }
  
      return $class->new( { resolvers => \@resolvers } );
  }
  
  sub validate_attributes {
      my ($self) = @_;
      my $resolvers = $self->resolvers;
      return 1;
  }
  
  # have to think carefully about the sematics of regex search when indices
  # are stacked; only one result for any given package (or package/version)
  sub search_packages {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_packages must be hash reference")
        unless ref $args eq 'HASH';
      my @found;
      if ( $args->{name} and ref $args->{name} eq '' ) {
          # looking for exact match, so we just want the first hit
          for my $source ( @{ $self->resolvers } ) {
              if ( my @result = $source->search_packages($args) ) {
                  # XXX double check against remaining $args
                  push @found, @result;
                  last;
              }
          }
      }
      else {
          # accumulate results from all resolvers
          my %seen;
          for my $source ( @{ $self->resolvers } ) {
              my @result = $source->search_packages($args);
              push @found, grep { !$seen{ $_->{package} }++ } @result;
          }
      }
      return wantarray ? @found : $found[0];
  }
  
  # have to think carefully about the sematics of regex search when indices
  # are stacked; only one result for any given package (or package/version)
  sub search_authors {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_authors must be hash reference")
        unless ref $args eq 'HASH';
      my @found;
      if ( $args->{name} and ref $args->{name} eq '' ) {
          # looking for exact match, so we just want the first hit
          for my $source ( @{ $self->resolvers } ) {
              if ( my @result = $source->search_authors($args) ) {
                  # XXX double check against remaining $args
                  push @found, @result;
                  last;
              }
          }
      }
      else {
          # accumulate results from all resolvers
          my %seen;
          for my $source ( @{ $self->resolvers } ) {
              my @result = $source->search_authors($args);
              push @found, grep { !$seen{ $_->{package} }++ } @result;
          }
      }
      return wantarray ? @found : $found[0];
  }
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Common::Index::Mux::Ordered - Consult indices in order and return the first result
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
      use CPAN::Common::Index::Mux::Ordered;
      use Data::Dumper;
  
      $index = CPAN::Common::Index::Mux::Ordered->assemble(
          MetaDB => {},
          Mirror => { mirror => "http://cpan.cpantesters.org" },
      );
  
  =head1 DESCRIPTION
  
  This module multiplexes multiple CPAN::Common::Index objects, returning
  results in order.
  
  For exact match queries, the first result is returned. For search queries,
  results from each index object are concatenated.
  
  =head1 ATTRIBUTES
  
  =head2 resolvers
  
      An array reference of CPAN::Common::Index::* objects
  
  =head1 METHODS
  
  =head2 assemble
  
      $index = CPAN::Common::Index::Mux::Ordered->assemble(
          MetaDB => {},
          Mirror => { mirror => "http://www.cpan.org" },
      );
  
  This class method provides a shorthand for constructing a multiplexer.
  The arguments must be pairs of subclass suffixes and arguments.  For
  example, "MetaDB" means to use "CPAN::Common::Index::MetaDB".  Empty
  arguments must be given as an empty hash reference.
  
  =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
CPAN_COMMON_INDEX_MUX_ORDERED

$fatpacked{"CPAN/DistnameInfo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_DISTNAMEINFO';
  
  package CPAN::DistnameInfo;
  
  $VERSION = "0.12";
  use strict;
  
  sub distname_info {
    my $file = shift or return;
  
    my ($dist, $version) = $file =~ /^
      ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
       (?:
  	[A-Za-z](?=[^A-Za-z]|$)
  	|
  	\d(?=-)
       )(?<![._-][vV])
      )+)(.*)
    $/xs or return ($file,undef,undef);
  
    if ($dist =~ /-undef\z/ and ! length $version) {
      $dist =~ s/-undef\z//;
    }
  
    # Remove potential -withoutworldwriteables suffix
    $version =~ s/-withoutworldwriteables$//;
  
    if ($version =~ /^(-[Vv].*)-(\d.*)/) {
     
      # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
      # where the V3_1_1 is part of the distname
      $dist .= $1;
      $version = $2;
    }
  
    if ($version =~ /(.+_.*)-(\d.*)/) {
        # Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
        # part of the distname. However, names like libao-perl_0.03-1.tar.gz
        # should still have 0.03-1 as their version.
        $dist .= $1;
        $version = $2;
    }
  
    # Normalize the Dist.pm-1.23 convention which CGI.pm and
    # a few others use.
    $dist =~ s{\.pm$}{};
  
    $version = $1
      if !length $version and $dist =~ s/-(\d+\w)$//;
  
    $version = $1 . $version
      if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
  
    if ($version =~ /\d\.\d/) {
      $version =~ s/^[-_.]+//;
    }
    else {
      $version =~ s/^[-_]+//;
    }
  
    my $dev;
    if (length $version) {
      if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
        $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
      }
      elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
        $dev = 1;
      }
    }
    else {
      $version = undef;
    }
  
    ($dist, $version, $dev);
  }
  
  sub new {
    my $class = shift;
    my $distfile = shift;
  
    $distfile =~ s,//+,/,g;
  
    my %info = ( pathname => $distfile );
  
    ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
      and $info{cpanid} = $6;
  
    if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
      $info{distvname} = $1;
      $info{extension} = $2;
    }
  
    @info{qw(dist version beta)} = distname_info($info{distvname});
    $info{maturity} = delete $info{beta} ? 'developer' : 'released';
  
    return bless \%info, $class;
  }
  
  sub dist      { shift->{dist} }
  sub version   { shift->{version} }
  sub maturity  { shift->{maturity} }
  sub filename  { shift->{filename} }
  sub cpanid    { shift->{cpanid} }
  sub distvname { shift->{distvname} }
  sub extension { shift->{extension} }
  sub pathname  { shift->{pathname} }
  
  sub properties { %{ $_[0] } }
  
  1;
  
  __END__
  
  =head1 NAME
  
  CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
  
  =head1 SYNOPSIS
  
    my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
  
    my $d = CPAN::DistnameInfo->new($pathname);
  
    my $dist      = $d->dist;      # "CPAN-DistnameInfo"
    my $version   = $d->version;   # "0.02"
    my $maturity  = $d->maturity;  # "released"
    my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
    my $cpanid    = $d->cpanid;    # "GBARR"
    my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
    my $extension = $d->extension; # "tar.gz"
    my $pathname  = $d->pathname;  # "authors/id/G/GB/GBARR/..."
  
    my %prop = $d->properties;
  
  =head1 DESCRIPTION
  
  Many online services that are centered around CPAN attempt to
  associate multiple uploads by extracting a distribution name from
  the filename of the upload. For most distributions this is easy as
  they have used ExtUtils::MakeMaker or Module::Build to create the
  distribution, which results in a uniform name. But sadly not all
  uploads are created in this way.
  
  C<CPAN::DistnameInfo> uses heuristics that have been learnt by
  L<http://search.cpan.org/> to extract the distribution name and
  version from filenames and also report if the version is to be
  treated as a developer release
  
  The constructor takes a single pathname, returning an object with the following methods
  
  =over
  
  =item cpanid
  
  If the path given looked like a CPAN authors directory path, then this will be the
  the CPAN id of the author.
  
  =item dist
  
  The name of the distribution
  
  =item distvname
  
  The file name with any suffix and leading directory names removed
  
  =item filename
  
  If the path given looked like a CPAN authors directory path, then this will be the
  path to the file relative to the detected CPAN author directory. Otherwise it is the path
  that was passed in.
  
  =item maturity
  
  The maturity of the distribution. This will be either C<released> or C<developer>
  
  =item extension
  
  The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
  
  =item pathname
  
  The pathname that was passed to the constructor when creating the object.
  
  =item properties
  
  This will return a list of key-value pairs, suitable for assigning to a hash,
  for the known properties.
  
  =item version
  
  The extracted version
  
  =back
  
  =head1 AUTHOR
  
  Graham Barr <gbarr@pobox.com>
  
  =head1 COPYRIGHT 
  
  Copyright (c) 2003 Graham Barr. All rights reserved. This program is
  free software; you can redistribute it and/or modify it under the same
  terms as Perl itself.
  
  =cut
  
CPAN_DISTNAMEINFO

$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META';
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta;
  
  our $VERSION = '2.150010';
  
  #pod =head1 SYNOPSIS
  #pod
  #pod     use v5.10;
  #pod     use strict;
  #pod     use warnings;
  #pod     use CPAN::Meta;
  #pod     use Module::Load;
  #pod
  #pod     my $meta = CPAN::Meta->load_file('META.json');
  #pod
  #pod     printf "testing requirements for %s version %s\n",
  #pod     $meta->name,
  #pod     $meta->version;
  #pod
  #pod     my $prereqs = $meta->effective_prereqs;
  #pod
  #pod     for my $phase ( qw/configure runtime build test/ ) {
  #pod         say "Requirements for $phase:";
  #pod         my $reqs = $prereqs->requirements_for($phase, "requires");
  #pod         for my $module ( sort $reqs->required_modules ) {
  #pod             my $status;
  #pod             if ( eval { load $module unless $module eq 'perl'; 1 } ) {
  #pod                 my $version = $module eq 'perl' ? $] : $module->VERSION;
  #pod                 $status = $reqs->accepts_module($module, $version)
  #pod                         ? "$version ok" : "$version not ok";
  #pod             } else {
  #pod                 $status = "missing"
  #pod             };
  #pod             say "  $module ($status)";
  #pod         }
  #pod     }
  #pod
  #pod =head1 DESCRIPTION
  #pod
  #pod Software distributions released to the CPAN include a F<META.json> or, for
  #pod older distributions, F<META.yml>, which describes the distribution, its
  #pod contents, and the requirements for building and installing the distribution.
  #pod The data structure stored in the F<META.json> file is described in
  #pod L<CPAN::Meta::Spec>.
  #pod
  #pod CPAN::Meta provides a simple class to represent this distribution metadata (or
  #pod I<distmeta>), along with some helpful methods for interrogating that data.
  #pod
  #pod The documentation below is only for the methods of the CPAN::Meta object.  For
  #pod information on the meaning of individual fields, consult the spec.
  #pod
  #pod =cut
  
  use Carp qw(carp croak);
  use CPAN::Meta::Feature;
  use CPAN::Meta::Prereqs;
  use CPAN::Meta::Converter;
  use CPAN::Meta::Validator;
  use Parse::CPAN::Meta 1.4414 ();
  
  BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
  
  #pod =head1 STRING DATA
  #pod
  #pod The following methods return a single value, which is the value for the
  #pod corresponding entry in the distmeta structure.  Values should be either undef
  #pod or strings.
  #pod
  #pod =for :list
  #pod * abstract
  #pod * description
  #pod * dynamic_config
  #pod * generated_by
  #pod * name
  #pod * release_status
  #pod * version
  #pod
  #pod =cut
  
  BEGIN {
    my @STRING_READERS = qw(
      abstract
      description
      dynamic_config
      generated_by
      name
      release_status
      version
    );
  
    no strict 'refs';
    for my $attr (@STRING_READERS) {
      *$attr = sub { $_[0]{ $attr } };
    }
  }
  
  #pod =head1 LIST DATA
  #pod
  #pod These methods return lists of string values, which might be represented in the
  #pod distmeta structure as arrayrefs or scalars:
  #pod
  #pod =for :list
  #pod * authors
  #pod * keywords
  #pod * licenses
  #pod
  #pod The C<authors> and C<licenses> methods may also be called as C<author> and
  #pod C<license>, respectively, to match the field name in the distmeta structure.
  #pod
  #pod =cut
  
  BEGIN {
    my @LIST_READERS = qw(
      author
      keywords
      license
    );
  
    no strict 'refs';
    for my $attr (@LIST_READERS) {
      *$attr = sub {
        my $value = $_[0]{ $attr };
        croak "$attr must be called in list context"
          unless wantarray;
        return @{ _dclone($value) } if ref $value;
        return $value;
      };
    }
  }
  
  sub authors  { $_[0]->author }
  sub licenses { $_[0]->license }
  
  #pod =head1 MAP DATA
  #pod
  #pod These readers return hashrefs of arbitrary unblessed data structures, each
  #pod described more fully in the specification:
  #pod
  #pod =for :list
  #pod * meta_spec
  #pod * resources
  #pod * provides
  #pod * no_index
  #pod * prereqs
  #pod * optional_features
  #pod
  #pod =cut
  
  BEGIN {
    my @MAP_READERS = qw(
      meta-spec
      resources
      provides
      no_index
  
      prereqs
      optional_features
    );
  
    no strict 'refs';
    for my $attr (@MAP_READERS) {
      (my $subname = $attr) =~ s/-/_/;
      *$subname = sub {
        my $value = $_[0]{ $attr };
        return _dclone($value) if $value;
        return {};
      };
    }
  }
  
  #pod =head1 CUSTOM DATA
  #pod
  #pod A list of custom keys are available from the C<custom_keys> method and
  #pod particular keys may be retrieved with the C<custom> method.
  #pod
  #pod   say $meta->custom($_) for $meta->custom_keys;
  #pod
  #pod If a custom key refers to a data structure, a deep clone is returned.
  #pod
  #pod =cut
  
  sub custom_keys {
    return grep { /^x_/i } keys %{$_[0]};
  }
  
  sub custom {
    my ($self, $attr) = @_;
    my $value = $self->{$attr};
    return _dclone($value) if ref $value;
    return $value;
  }
  
  #pod =method new
  #pod
  #pod   my $meta = CPAN::Meta->new($distmeta_struct, \%options);
  #pod
  #pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash
  #pod reference fails to validate.  Older-format metadata will be up-converted to
  #pod version 2 if they validate against the original stated specification.
  #pod
  #pod It takes an optional hashref of options. Valid options include:
  #pod
  #pod =over
  #pod
  #pod =item *
  #pod
  #pod lazy_validation -- if true, new will attempt to convert the given metadata
  #pod to version 2 before attempting to validate it.  This means than any
  #pod fixable errors will be handled by CPAN::Meta::Converter before validation.
  #pod (Note that this might result in invalid optional data being silently
  #pod dropped.)  The default is false.
  #pod
  #pod =back
  #pod
  #pod =cut
  
  sub _new {
    my ($class, $struct, $options) = @_;
    my $self;
  
    if ( $options->{lazy_validation} ) {
      # try to convert to a valid structure; if succeeds, then return it
      my $cmc = CPAN::Meta::Converter->new( $struct );
      $self = $cmc->convert( version => 2 ); # valid or dies
      return bless $self, $class;
    }
    else {
      # validate original struct
      my $cmv = CPAN::Meta::Validator->new( $struct );
      unless ( $cmv->is_valid) {
        die "Invalid metadata structure. Errors: "
          . join(", ", $cmv->errors) . "\n";
      }
    }
  
    # up-convert older spec versions
    my $version = $struct->{'meta-spec'}{version} || '1.0';
    if ( $version == 2 ) {
      $self = $struct;
    }
    else {
      my $cmc = CPAN::Meta::Converter->new( $struct );
      $self = $cmc->convert( version => 2 );
    }
  
    return bless $self, $class;
  }
  
  sub new {
    my ($class, $struct, $options) = @_;
    my $self = eval { $class->_new($struct, $options) };
    croak($@) if $@;
    return $self;
  }
  
  #pod =method create
  #pod
  #pod   my $meta = CPAN::Meta->create($distmeta_struct, \%options);
  #pod
  #pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
  #pod will be generated if not provided.  This means the metadata structure is
  #pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
  #pod
  #pod =cut
  
  sub create {
    my ($class, $struct, $options) = @_;
    my $version = __PACKAGE__->VERSION || 2;
    $struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
    $struct->{'meta-spec'}{version} ||= int($version);
    my $self = eval { $class->_new($struct, $options) };
    croak ($@) if $@;
    return $self;
  }
  
  #pod =method load_file
  #pod
  #pod   my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
  #pod
  #pod Given a pathname to a file containing metadata, this deserializes the file
  #pod according to its file suffix and constructs a new C<CPAN::Meta> object, just
  #pod like C<new()>.  It will die if the deserialized version fails to validate
  #pod against its stated specification version.
  #pod
  #pod It takes the same options as C<new()> but C<lazy_validation> defaults to
  #pod true.
  #pod
  #pod =cut
  
  sub load_file {
    my ($class, $file, $options) = @_;
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  
    croak "load_file() requires a valid, readable filename"
      unless -r $file;
  
    my $self;
    eval {
      my $struct = Parse::CPAN::Meta->load_file( $file );
      $self = $class->_new($struct, $options);
    };
    croak($@) if $@;
    return $self;
  }
  
  #pod =method load_yaml_string
  #pod
  #pod   my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
  #pod
  #pod This method returns a new CPAN::Meta object using the first document in the
  #pod given YAML string.  In other respects it is identical to C<load_file()>.
  #pod
  #pod =cut
  
  sub load_yaml_string {
    my ($class, $yaml, $options) = @_;
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  
    my $self;
    eval {
      my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
      $self = $class->_new($struct, $options);
    };
    croak($@) if $@;
    return $self;
  }
  
  #pod =method load_json_string
  #pod
  #pod   my $meta = CPAN::Meta->load_json_string($json, \%options);
  #pod
  #pod This method returns a new CPAN::Meta object using the structure represented by
  #pod the given JSON string.  In other respects it is identical to C<load_file()>.
  #pod
  #pod =cut
  
  sub load_json_string {
    my ($class, $json, $options) = @_;
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  
    my $self;
    eval {
      my $struct = Parse::CPAN::Meta->load_json_string( $json );
      $self = $class->_new($struct, $options);
    };
    croak($@) if $@;
    return $self;
  }
  
  #pod =method load_string
  #pod
  #pod   my $meta = CPAN::Meta->load_string($string, \%options);
  #pod
  #pod If you don't know if a string contains YAML or JSON, this method will use
  #pod L<Parse::CPAN::Meta> to guess.  In other respects it is identical to
  #pod C<load_file()>.
  #pod
  #pod =cut
  
  sub load_string {
    my ($class, $string, $options) = @_;
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  
    my $self;
    eval {
      my $struct = Parse::CPAN::Meta->load_string( $string );
      $self = $class->_new($struct, $options);
    };
    croak($@) if $@;
    return $self;
  }
  
  #pod =method save
  #pod
  #pod   $meta->save($distmeta_file, \%options);
  #pod
  #pod Serializes the object as JSON and writes it to the given file.  The only valid
  #pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
  #pod is saved with UTF-8 encoding.
  #pod
  #pod For C<version> 2 (or higher), the filename should end in '.json'.  L<JSON::PP>
  #pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
  #pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
  #pod backend like L<JSON::XS>.
  #pod
  #pod For C<version> less than 2, the filename should end in '.yml'.
  #pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
  #pod is serialized to YAML.  CPAN::Meta::YAML is the default YAML backend.  You may
  #pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
  #pod this is not recommended due to subtle incompatibilities between YAML parsers on
  #pod CPAN.
  #pod
  #pod =cut
  
  sub save {
    my ($self, $file, $options) = @_;
  
    my $version = $options->{version} || '2';
    my $layer = $] ge '5.008001' ? ':utf8' : '';
  
    if ( $version ge '2' ) {
      carp "'$file' should end in '.json'"
        unless $file =~ m{\.json$};
    }
    else {
      carp "'$file' should end in '.yml'"
        unless $file =~ m{\.yml$};
    }
  
    my $data = $self->as_string( $options );
    open my $fh, ">$layer", $file
      or die "Error opening '$file' for writing: $!\n";
  
    print {$fh} $data;
    close $fh
      or die "Error closing '$file': $!\n";
  
    return 1;
  }
  
  #pod =method meta_spec_version
  #pod
  #pod This method returns the version part of the C<meta_spec> entry in the distmeta
  #pod structure.  It is equivalent to:
  #pod
  #pod   $meta->meta_spec->{version};
  #pod
  #pod =cut
  
  sub meta_spec_version {
    my ($self) = @_;
    return $self->meta_spec->{version};
  }
  
  #pod =method effective_prereqs
  #pod
  #pod   my $prereqs = $meta->effective_prereqs;
  #pod
  #pod   my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
  #pod
  #pod This method returns a L<CPAN::Meta::Prereqs> object describing all the
  #pod prereqs for the distribution.  If an arrayref of feature identifiers is given,
  #pod the prereqs for the identified features are merged together with the
  #pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
  #pod
  #pod =cut
  
  sub effective_prereqs {
    my ($self, $features) = @_;
    $features ||= [];
  
    my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
  
    return $prereq unless @$features;
  
    my @other = map {; $self->feature($_)->prereqs } @$features;
  
    return $prereq->with_merged_prereqs(\@other);
  }
  
  #pod =method should_index_file
  #pod
  #pod   ... if $meta->should_index_file( $filename );
  #pod
  #pod This method returns true if the given file should be indexed.  It decides this
  #pod by checking the C<file> and C<directory> keys in the C<no_index> property of
  #pod the distmeta structure. Note that neither the version format nor
  #pod C<release_status> are considered.
  #pod
  #pod C<$filename> should be given in unix format.
  #pod
  #pod =cut
  
  sub should_index_file {
    my ($self, $filename) = @_;
  
    for my $no_index_file (@{ $self->no_index->{file} || [] }) {
      return if $filename eq $no_index_file;
    }
  
    for my $no_index_dir (@{ $self->no_index->{directory} }) {
      $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
      return if index($filename, $no_index_dir) == 0;
    }
  
    return 1;
  }
  
  #pod =method should_index_package
  #pod
  #pod   ... if $meta->should_index_package( $package );
  #pod
  #pod This method returns true if the given package should be indexed.  It decides
  #pod this by checking the C<package> and C<namespace> keys in the C<no_index>
  #pod property of the distmeta structure. Note that neither the version format nor
  #pod C<release_status> are considered.
  #pod
  #pod =cut
  
  sub should_index_package {
    my ($self, $package) = @_;
  
    for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
      return if $package eq $no_index_pkg;
    }
  
    for my $no_index_ns (@{ $self->no_index->{namespace} }) {
      return if index($package, "${no_index_ns}::") == 0;
    }
  
    return 1;
  }
  
  #pod =method features
  #pod
  #pod   my @feature_objects = $meta->features;
  #pod
  #pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each
  #pod optional feature described by the distribution's metadata.
  #pod
  #pod =cut
  
  sub features {
    my ($self) = @_;
  
    my $opt_f = $self->optional_features;
    my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
                   keys %$opt_f;
  
    return @features;
  }
  
  #pod =method feature
  #pod
  #pod   my $feature_object = $meta->feature( $identifier );
  #pod
  #pod This method returns a L<CPAN::Meta::Feature> object for the optional feature
  #pod with the given identifier.  If no feature with that identifier exists, an
  #pod exception will be raised.
  #pod
  #pod =cut
  
  sub feature {
    my ($self, $ident) = @_;
  
    croak "no feature named $ident"
      unless my $f = $self->optional_features->{ $ident };
  
    return CPAN::Meta::Feature->new($ident, $f);
  }
  
  #pod =method as_struct
  #pod
  #pod   my $copy = $meta->as_struct( \%options );
  #pod
  #pod This method returns a deep copy of the object's metadata as an unblessed hash
  #pod reference.  It takes an optional hashref of options.  If the hashref contains
  #pod a C<version> argument, the copied metadata will be converted to the version
  #pod of the specification and returned.  For example:
  #pod
  #pod   my $old_spec = $meta->as_struct( {version => "1.4"} );
  #pod
  #pod =cut
  
  sub as_struct {
    my ($self, $options) = @_;
    my $struct = _dclone($self);
    if ( $options->{version} ) {
      my $cmc = CPAN::Meta::Converter->new( $struct );
      $struct = $cmc->convert( version => $options->{version} );
    }
    return $struct;
  }
  
  #pod =method as_string
  #pod
  #pod   my $string = $meta->as_string( \%options );
  #pod
  #pod This method returns a serialized copy of the object's metadata as a character
  #pod string.  (The strings are B<not> UTF-8 encoded.)  It takes an optional hashref
  #pod of options.  If the hashref contains a C<version> argument, the copied metadata
  #pod will be converted to the version of the specification and returned.  For
  #pod example:
  #pod
  #pod   my $string = $meta->as_string( {version => "1.4"} );
  #pod
  #pod For C<version> greater than or equal to 2, the string will be serialized as
  #pod JSON.  For C<version> less than 2, the string will be serialized as YAML.  In
  #pod both cases, the same rules are followed as in the C<save()> method for choosing
  #pod a serialization backend.
  #pod
  #pod The serialized structure will include a C<x_serialization_backend> entry giving
  #pod the package and version used to serialize.  Any existing key in the given
  #pod C<$meta> object will be clobbered.
  #pod
  #pod =cut
  
  sub as_string {
    my ($self, $options) = @_;
  
    my $version = $options->{version} || '2';
  
    my $struct;
    if ( $self->meta_spec_version ne $version ) {
      my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
      $struct = $cmc->convert( version => $version );
    }
    else {
      $struct = $self->as_struct;
    }
  
    my ($data, $backend);
    if ( $version ge '2' ) {
      $backend = Parse::CPAN::Meta->json_backend();
      local $struct->{x_serialization_backend} = sprintf '%s version %s',
        $backend, $backend->VERSION;
      $data = $backend->new->pretty->canonical->encode($struct);
    }
    else {
      $backend = Parse::CPAN::Meta->yaml_backend();
      local $struct->{x_serialization_backend} = sprintf '%s version %s',
        $backend, $backend->VERSION;
      $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
      if ( $@ ) {
        croak $backend->can('errstr') ? $backend->errstr : $@
      }
    }
  
    return $data;
  }
  
  # Used by JSON::PP, etc. for "convert_blessed"
  sub TO_JSON {
    return { %{ $_[0] } };
  }
  
  1;
  
  # ABSTRACT: the distribution metadata for a CPAN dist
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta - the distribution metadata for a CPAN dist
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 SYNOPSIS
  
      use v5.10;
      use strict;
      use warnings;
      use CPAN::Meta;
      use Module::Load;
  
      my $meta = CPAN::Meta->load_file('META.json');
  
      printf "testing requirements for %s version %s\n",
      $meta->name,
      $meta->version;
  
      my $prereqs = $meta->effective_prereqs;
  
      for my $phase ( qw/configure runtime build test/ ) {
          say "Requirements for $phase:";
          my $reqs = $prereqs->requirements_for($phase, "requires");
          for my $module ( sort $reqs->required_modules ) {
              my $status;
              if ( eval { load $module unless $module eq 'perl'; 1 } ) {
                  my $version = $module eq 'perl' ? $] : $module->VERSION;
                  $status = $reqs->accepts_module($module, $version)
                          ? "$version ok" : "$version not ok";
              } else {
                  $status = "missing"
              };
              say "  $module ($status)";
          }
      }
  
  =head1 DESCRIPTION
  
  Software distributions released to the CPAN include a F<META.json> or, for
  older distributions, F<META.yml>, which describes the distribution, its
  contents, and the requirements for building and installing the distribution.
  The data structure stored in the F<META.json> file is described in
  L<CPAN::Meta::Spec>.
  
  CPAN::Meta provides a simple class to represent this distribution metadata (or
  I<distmeta>), along with some helpful methods for interrogating that data.
  
  The documentation below is only for the methods of the CPAN::Meta object.  For
  information on the meaning of individual fields, consult the spec.
  
  =head1 METHODS
  
  =head2 new
  
    my $meta = CPAN::Meta->new($distmeta_struct, \%options);
  
  Returns a valid CPAN::Meta object or dies if the supplied metadata hash
  reference fails to validate.  Older-format metadata will be up-converted to
  version 2 if they validate against the original stated specification.
  
  It takes an optional hashref of options. Valid options include:
  
  =over
  
  =item *
  
  lazy_validation -- if true, new will attempt to convert the given metadata
  to version 2 before attempting to validate it.  This means than any
  fixable errors will be handled by CPAN::Meta::Converter before validation.
  (Note that this might result in invalid optional data being silently
  dropped.)  The default is false.
  
  =back
  
  =head2 create
  
    my $meta = CPAN::Meta->create($distmeta_struct, \%options);
  
  This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
  will be generated if not provided.  This means the metadata structure is
  assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
  
  =head2 load_file
  
    my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
  
  Given a pathname to a file containing metadata, this deserializes the file
  according to its file suffix and constructs a new C<CPAN::Meta> object, just
  like C<new()>.  It will die if the deserialized version fails to validate
  against its stated specification version.
  
  It takes the same options as C<new()> but C<lazy_validation> defaults to
  true.
  
  =head2 load_yaml_string
  
    my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
  
  This method returns a new CPAN::Meta object using the first document in the
  given YAML string.  In other respects it is identical to C<load_file()>.
  
  =head2 load_json_string
  
    my $meta = CPAN::Meta->load_json_string($json, \%options);
  
  This method returns a new CPAN::Meta object using the structure represented by
  the given JSON string.  In other respects it is identical to C<load_file()>.
  
  =head2 load_string
  
    my $meta = CPAN::Meta->load_string($string, \%options);
  
  If you don't know if a string contains YAML or JSON, this method will use
  L<Parse::CPAN::Meta> to guess.  In other respects it is identical to
  C<load_file()>.
  
  =head2 save
  
    $meta->save($distmeta_file, \%options);
  
  Serializes the object as JSON and writes it to the given file.  The only valid
  option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
  is saved with UTF-8 encoding.
  
  For C<version> 2 (or higher), the filename should end in '.json'.  L<JSON::PP>
  is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
  later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
  backend like L<JSON::XS>.
  
  For C<version> less than 2, the filename should end in '.yml'.
  L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
  is serialized to YAML.  CPAN::Meta::YAML is the default YAML backend.  You may
  set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
  this is not recommended due to subtle incompatibilities between YAML parsers on
  CPAN.
  
  =head2 meta_spec_version
  
  This method returns the version part of the C<meta_spec> entry in the distmeta
  structure.  It is equivalent to:
  
    $meta->meta_spec->{version};
  
  =head2 effective_prereqs
  
    my $prereqs = $meta->effective_prereqs;
  
    my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
  
  This method returns a L<CPAN::Meta::Prereqs> object describing all the
  prereqs for the distribution.  If an arrayref of feature identifiers is given,
  the prereqs for the identified features are merged together with the
  distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
  
  =head2 should_index_file
  
    ... if $meta->should_index_file( $filename );
  
  This method returns true if the given file should be indexed.  It decides this
  by checking the C<file> and C<directory> keys in the C<no_index> property of
  the distmeta structure. Note that neither the version format nor
  C<release_status> are considered.
  
  C<$filename> should be given in unix format.
  
  =head2 should_index_package
  
    ... if $meta->should_index_package( $package );
  
  This method returns true if the given package should be indexed.  It decides
  this by checking the C<package> and C<namespace> keys in the C<no_index>
  property of the distmeta structure. Note that neither the version format nor
  C<release_status> are considered.
  
  =head2 features
  
    my @feature_objects = $meta->features;
  
  This method returns a list of L<CPAN::Meta::Feature> objects, one for each
  optional feature described by the distribution's metadata.
  
  =head2 feature
  
    my $feature_object = $meta->feature( $identifier );
  
  This method returns a L<CPAN::Meta::Feature> object for the optional feature
  with the given identifier.  If no feature with that identifier exists, an
  exception will be raised.
  
  =head2 as_struct
  
    my $copy = $meta->as_struct( \%options );
  
  This method returns a deep copy of the object's metadata as an unblessed hash
  reference.  It takes an optional hashref of options.  If the hashref contains
  a C<version> argument, the copied metadata will be converted to the version
  of the specification and returned.  For example:
  
    my $old_spec = $meta->as_struct( {version => "1.4"} );
  
  =head2 as_string
  
    my $string = $meta->as_string( \%options );
  
  This method returns a serialized copy of the object's metadata as a character
  string.  (The strings are B<not> UTF-8 encoded.)  It takes an optional hashref
  of options.  If the hashref contains a C<version> argument, the copied metadata
  will be converted to the version of the specification and returned.  For
  example:
  
    my $string = $meta->as_string( {version => "1.4"} );
  
  For C<version> greater than or equal to 2, the string will be serialized as
  JSON.  For C<version> less than 2, the string will be serialized as YAML.  In
  both cases, the same rules are followed as in the C<save()> method for choosing
  a serialization backend.
  
  The serialized structure will include a C<x_serialization_backend> entry giving
  the package and version used to serialize.  Any existing key in the given
  C<$meta> object will be clobbered.
  
  =head1 STRING DATA
  
  The following methods return a single value, which is the value for the
  corresponding entry in the distmeta structure.  Values should be either undef
  or strings.
  
  =over 4
  
  =item *
  
  abstract
  
  =item *
  
  description
  
  =item *
  
  dynamic_config
  
  =item *
  
  generated_by
  
  =item *
  
  name
  
  =item *
  
  release_status
  
  =item *
  
  version
  
  =back
  
  =head1 LIST DATA
  
  These methods return lists of string values, which might be represented in the
  distmeta structure as arrayrefs or scalars:
  
  =over 4
  
  =item *
  
  authors
  
  =item *
  
  keywords
  
  =item *
  
  licenses
  
  =back
  
  The C<authors> and C<licenses> methods may also be called as C<author> and
  C<license>, respectively, to match the field name in the distmeta structure.
  
  =head1 MAP DATA
  
  These readers return hashrefs of arbitrary unblessed data structures, each
  described more fully in the specification:
  
  =over 4
  
  =item *
  
  meta_spec
  
  =item *
  
  resources
  
  =item *
  
  provides
  
  =item *
  
  no_index
  
  =item *
  
  prereqs
  
  =item *
  
  optional_features
  
  =back
  
  =head1 CUSTOM DATA
  
  A list of custom keys are available from the C<custom_keys> method and
  particular keys may be retrieved with the C<custom> method.
  
    say $meta->custom($_) for $meta->custom_keys;
  
  If a custom key refers to a data structure, a deep clone is returned.
  
  =for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
  generated_by keywords license licenses meta_spec name no_index
  optional_features prereqs provides release_status resources version
  
  =head1 BUGS
  
  Please report any bugs or feature using the CPAN Request Tracker.
  Bugs can be submitted through the web interface at
  L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
  
  When submitting a bug or request, please include a test-file or a patch to an
  existing test-file that illustrates the bug or desired feature.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<CPAN::Meta::Converter>
  
  =item *
  
  L<CPAN::Meta::Validator>
  
  =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/Perl-Toolchain-Gang/CPAN-Meta/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/Perl-Toolchain-Gang/CPAN-Meta>
  
    git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Benjamin Noggle Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov David Golden Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Kent Fredric Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern Mohammad Anwar mohawk2 moznion Niko Tyni Olaf Alders Olivier Mengué Randy Sims Tomohiro Hosaka
  
  =over 4
  
  =item *
  
  Ansgar Burchardt <ansgar@cpan.org>
  
  =item *
  
  Avar Arnfjord Bjarmason <avar@cpan.org>
  
  =item *
  
  Benjamin Noggle <agwind@users.noreply.github.com>
  
  =item *
  
  Christopher J. Madsen <cjm@cpan.org>
  
  =item *
  
  Chuck Adams <cja987@gmail.com>
  
  =item *
  
  Cory G Watson <gphat@cpan.org>
  
  =item *
  
  Damyan Ivanov <dam@cpan.org>
  
  =item *
  
  David Golden <xdg@xdg.me>
  
  =item *
  
  Eric Wilhelm <ewilhelm@cpan.org>
  
  =item *
  
  Graham Knop <haarg@haarg.org>
  
  =item *
  
  Gregor Hermann <gregoa@debian.org>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Kenichi Ishigaki <ishigaki@cpan.org>
  
  =item *
  
  Kent Fredric <kentfredric@gmail.com>
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Lars Dieckow <daxim@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =item *
  
  majensen <maj@fortinbras.us>
  
  =item *
  
  Mark Fowler <markf@cpan.org>
  
  =item *
  
  Matt S Trout <mst@shadowcat.co.uk>
  
  =item *
  
  Michael G. Schwern <mschwern@cpan.org>
  
  =item *
  
  Mohammad S Anwar <mohammad.anwar@yahoo.com>
  
  =item *
  
  mohawk2 <mohawk2@users.noreply.github.com>
  
  =item *
  
  moznion <moznion@gmail.com>
  
  =item *
  
  Niko Tyni <ntyni@debian.org>
  
  =item *
  
  Olaf Alders <olaf@wundersolutions.com>
  
  =item *
  
  Olivier Mengué <dolmen@cpan.org>
  
  =item *
  
  Randy Sims <randys@thepierianspring.org>
  
  =item *
  
  Tomohiro Hosaka <bokutin@bokut.in>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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
  
  __END__
  
  
  # vim: ts=2 sts=2 sw=2 et :
CPAN_META

$fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK';
  package CPAN::Meta::Check;
  $CPAN::Meta::Check::VERSION = '0.014';
  use strict;
  use warnings;
  
  use base 'Exporter';
  our @EXPORT = qw//;
  our @EXPORT_OK = qw/check_requirements requirements_for verify_dependencies/;
  our %EXPORT_TAGS = (all => [ @EXPORT, @EXPORT_OK ] );
  
  use CPAN::Meta::Prereqs '2.132830';
  use CPAN::Meta::Requirements 2.121;
  use Module::Metadata 1.000023;
  
  sub _check_dep {
  	my ($reqs, $module, $dirs) = @_;
  
  	$module eq 'perl' and return ($reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module));
  
  	my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
  	return "Module '$module' is not installed" if not defined $metadata;
  
  	my $version = eval { $metadata->version };
  	return sprintf 'Installed version (%s) of %s is not in range \'%s\'',
  			(defined $version ? $version : 'undef'), $module, $reqs->requirements_for_module($module)
  		if not $reqs->accepts_module($module, $version || 0);
  	return;
  }
  
  sub _check_conflict {
  	my ($reqs, $module, $dirs) = @_;
  	my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
  	return if not defined $metadata;
  
  	my $version = eval { $metadata->version };
  	return sprintf 'Installed version (%s) of %s is in range \'%s\'',
  			(defined $version ? $version : 'undef'), $module, $reqs->requirements_for_module($module)
  		if $reqs->accepts_module($module, $version);
  	return;
  }
  
  sub requirements_for {
  	my ($meta, $phases, $type) = @_;
  	my $prereqs = ref($meta) eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;
  	return $prereqs->merged_requirements(ref($phases) ? $phases : [ $phases ], [ $type ]);
  }
  
  sub check_requirements {
  	my ($reqs, $type, $dirs) = @_;
  
  	return +{
  		map {
  			$_ => $type ne 'conflicts'
  				? scalar _check_dep($reqs, $_, $dirs)
  				: scalar _check_conflict($reqs, $_, $dirs)
  		} $reqs->required_modules
  	};
  }
  
  sub verify_dependencies {
  	my ($meta, $phases, $type, $dirs) = @_;
  	my $reqs = requirements_for($meta, $phases, $type);
  	my $issues = check_requirements($reqs, $type, $dirs);
  	return grep { defined } values %{ $issues };
  }
  
  1;
  
  #ABSTRACT: Verify requirements in a CPAN::Meta object
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Check - Verify requirements in a CPAN::Meta object
  
  =head1 VERSION
  
  version 0.014
  
  =head1 SYNOPSIS
  
   warn "$_\n" for verify_dependencies($meta, [qw/runtime build test/], 'requires');
  
  =head1 DESCRIPTION
  
  This module verifies if requirements described in a CPAN::Meta object are present.
  
  =head1 FUNCTIONS
  
  =head2 check_requirements($reqs, $type, $incdirs)
  
  This function checks if all dependencies in C<$reqs> (a L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object) are met, taking into account that 'conflicts' dependencies have to be checked in reverse. It returns a hash with the modules as keys and any problems as values; the value for a successfully found module will be undef. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
  
  =head2 verify_dependencies($meta, $phases, $types, $incdirs)
  
  Check all requirements in C<$meta> for phases C<$phases> and type C<$type>. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
  
  =head2 requirements_for($meta, $phases, $types)
  
  B<< This function is deprecated and may be removed at some point in the future, please use CPAN::Meta::Prereqs->merged_requirements instead. >>
  
  This function returns a unified L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object for all C<$type> requirements for C<$phases>. C<$phases> may be either one (scalar) value or an arrayref of valid values as defined by the L<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Test::CheckDeps|Test::CheckDeps>
  
  =item * L<CPAN::Meta|CPAN::Meta>
  
  =for comment # vi:noet:sts=2:sw=2:ts=2
  
  =back
  
  =head1 AUTHOR
  
  Leon Timmermans <leont@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Leon Timmermans.
  
  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_META_CHECK

$fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER';
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta::Converter;
  
  our $VERSION = '2.150010';
  
  #pod =head1 SYNOPSIS
  #pod
  #pod   my $struct = decode_json_file('META.json');
  #pod
  #pod   my $cmc = CPAN::Meta::Converter->new( $struct );
  #pod
  #pod   my $new_struct = $cmc->convert( version => "2" );
  #pod
  #pod =head1 DESCRIPTION
  #pod
  #pod This module converts CPAN Meta structures from one form to another.  The
  #pod primary use is to convert older structures to the most modern version of
  #pod the specification, but other transformations may be implemented in the
  #pod future as needed.  (E.g. stripping all custom fields or stripping all
  #pod optional fields.)
  #pod
  #pod =cut
  
  use CPAN::Meta::Validator;
  use CPAN::Meta::Requirements;
  use Parse::CPAN::Meta 1.4400 ();
  
  # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
  # before 5.10, we fall back to the EUMM bundled compatibility version module if
  # that's the only thing available.  This shouldn't ever happen in a normal CPAN
  # install of CPAN::Meta::Requirements, as version.pm will be picked up from
  # prereqs and be available at runtime.
  
  BEGIN {
    eval "use version ()"; ## no critic
    if ( my $err = $@ ) {
      eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
    }
  }
  
  # Perl 5.10.0 didn't have "is_qv" in version.pm
  *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
  
  # We limit cloning to a maximum depth to bail out on circular data
  # structures.  While actual cycle detection might be technically better,
  # we expect circularity in META data structures to be rare and generally
  # the result of user error.  Therefore, a depth counter is lower overhead.
  our $DCLONE_MAXDEPTH = 1024;
  our $_CLONE_DEPTH;
  
  sub _dclone {
    my ( $ref  ) = @_;
    return $ref unless my $reftype = ref $ref;
  
    local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
    die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
  
    return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
    return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
  
    if ( 'SCALAR' eq $reftype ) {
      my $new = _dclone(${$ref});
      return \$new;
    }
  
    # We can't know if TO_JSON gives us cloned data, so refs must recurse
    if ( eval { $ref->can('TO_JSON') } ) {
      my $data = $ref->TO_JSON;
      return ref $data ? _dclone( $data ) : $data;
    }
  
    # Just stringify everything else
    return "$ref";
  }
  
  my %known_specs = (
      '2'   => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
      '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
      '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
      '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
      '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
      '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
  );
  
  my @spec_list = sort { $a <=> $b } keys %known_specs;
  my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
  
  #--------------------------------------------------------------------------#
  # converters
  #
  # called as $converter->($element, $field_name, $full_meta, $to_version)
  #
  # defined return value used for field
  # undef return value means field is skipped
  #--------------------------------------------------------------------------#
  
  sub _keep { $_[0] }
  
  sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
  
  sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
  
  sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
  
  sub _generated_by {
    my $gen = shift;
    my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
  
    return $sig unless defined $gen and length $gen;
    return $gen if $gen =~ /\Q$sig/;
    return "$gen, $sig";
  }
  
  sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
  
  sub _prefix_custom {
    my $key = shift;
    $key =~ s/^(?!x_)   # Unless it already starts with x_
               (?:x-?)? # Remove leading x- or x (if present)
             /x_/ix;    # and prepend x_
    return $key;
  }
  
  sub _ucfirst_custom {
    my $key = shift;
    $key = ucfirst $key unless $key =~ /[A-Z]/;
    return $key;
  }
  
  sub _no_prefix_ucfirst_custom {
    my $key = shift;
    $key =~ s/^x_//;
    return _ucfirst_custom($key);
  }
  
  sub _change_meta_spec {
    my ($element, undef, undef, $version) = @_;
    return {
      version => $version,
      url => $known_specs{$version},
    };
  }
  
  my @open_source = (
    'perl',
    'gpl',
    'apache',
    'artistic',
    'artistic_2',
    'lgpl',
    'bsd',
    'gpl',
    'mit',
    'mozilla',
    'open_source',
  );
  
  my %is_open_source = map {; $_ => 1 } @open_source;
  
  my @valid_licenses_1 = (
    @open_source,
    'unrestricted',
    'restrictive',
    'unknown',
  );
  
  my %license_map_1 = (
    ( map { $_ => $_ } @valid_licenses_1 ),
    artistic2 => 'artistic_2',
  );
  
  sub _license_1 {
    my ($element) = @_;
    return 'unknown' unless defined $element;
    if ( $license_map_1{lc $element} ) {
      return $license_map_1{lc $element};
    }
    else {
      return 'unknown';
    }
  }
  
  my @valid_licenses_2 = qw(
    agpl_3
    apache_1_1
    apache_2_0
    artistic_1
    artistic_2
    bsd
    freebsd
    gfdl_1_2
    gfdl_1_3
    gpl_1
    gpl_2
    gpl_3
    lgpl_2_1
    lgpl_3_0
    mit
    mozilla_1_0
    mozilla_1_1
    openssl
    perl_5
    qpl_1_0
    ssleay
    sun
    zlib
    open_source
    restricted
    unrestricted
    unknown
  );
  
  # The "old" values were defined by Module::Build, and were often vague.  I have
  # made the decisions below based on reading Module::Build::API and how clearly
  # it specifies the version of the license.
  my %license_map_2 = (
    (map { $_ => $_ } @valid_licenses_2),
    apache      => 'apache_2_0',  # clearly stated as 2.0
    artistic    => 'artistic_1',  # clearly stated as 1
    artistic2   => 'artistic_2',  # clearly stated as 2
    gpl         => 'open_source', # we don't know which GPL; punt
    lgpl        => 'open_source', # we don't know which LGPL; punt
    mozilla     => 'open_source', # we don't know which MPL; punt
    perl        => 'perl_5',      # clearly Perl 5
    restrictive => 'restricted',
  );
  
  sub _license_2 {
    my ($element) = @_;
    return [ 'unknown' ] unless defined $element;
    $element = [ $element ] unless ref $element eq 'ARRAY';
    my @new_list;
    for my $lic ( @$element ) {
      next unless defined $lic;
      if ( my $new = $license_map_2{lc $lic} ) {
        push @new_list, $new;
      }
    }
    return @new_list ? \@new_list : [ 'unknown' ];
  }
  
  my %license_downgrade_map = qw(
    agpl_3            open_source
    apache_1_1        apache
    apache_2_0        apache
    artistic_1        artistic
    artistic_2        artistic_2
    bsd               bsd
    freebsd           open_source
    gfdl_1_2          open_source
    gfdl_1_3          open_source
    gpl_1             gpl
    gpl_2             gpl
    gpl_3             gpl
    lgpl_2_1          lgpl
    lgpl_3_0          lgpl
    mit               mit
    mozilla_1_0       mozilla
    mozilla_1_1       mozilla
    openssl           open_source
    perl_5            perl
    qpl_1_0           open_source
    ssleay            open_source
    sun               open_source
    zlib              open_source
    open_source       open_source
    restricted        restrictive
    unrestricted      unrestricted
    unknown           unknown
  );
  
  sub _downgrade_license {
    my ($element) = @_;
    if ( ! defined $element ) {
      return "unknown";
    }
    elsif( ref $element eq 'ARRAY' ) {
      if ( @$element > 1) {
        if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
          return 'unknown';
        }
        else {
          return 'open_source';
        }
      }
      elsif ( @$element == 1 ) {
        return $license_downgrade_map{lc $element->[0]} || "unknown";
      }
    }
    elsif ( ! ref $element ) {
      return $license_downgrade_map{lc $element} || "unknown";
    }
    return "unknown";
  }
  
  my $no_index_spec_1_2 = {
    'file' => \&_listify,
    'dir' => \&_listify,
    'package' => \&_listify,
    'namespace' => \&_listify,
  };
  
  my $no_index_spec_1_3 = {
    'file' => \&_listify,
    'directory' => \&_listify,
    'package' => \&_listify,
    'namespace' => \&_listify,
  };
  
  my $no_index_spec_2 = {
    'file' => \&_listify,
    'directory' => \&_listify,
    'package' => \&_listify,
    'namespace' => \&_listify,
    ':custom'  => \&_prefix_custom,
  };
  
  sub _no_index_1_2 {
    my (undef, undef, $meta) = @_;
    my $no_index = $meta->{no_index} || $meta->{private};
    return unless $no_index;
  
    # cleanup wrong format
    if ( ! ref $no_index ) {
      my $item = $no_index;
      $no_index = { dir => [ $item ], file => [ $item ] };
    }
    elsif ( ref $no_index eq 'ARRAY' ) {
      my $list = $no_index;
      $no_index = { dir => [ @$list ], file => [ @$list ] };
    }
  
    # common mistake: files -> file
    if ( exists $no_index->{files} ) {
      $no_index->{file} = delete $no_index->{files};
    }
    # common mistake: modules -> module
    if ( exists $no_index->{modules} ) {
      $no_index->{module} = delete $no_index->{modules};
    }
    return _convert($no_index, $no_index_spec_1_2);
  }
  
  sub _no_index_directory {
    my ($element, $key, $meta, $version) = @_;
    return unless $element;
  
    # clean up wrong format
    if ( ! ref $element ) {
      my $item = $element;
      $element = { directory => [ $item ], file => [ $item ] };
    }
    elsif ( ref $element eq 'ARRAY' ) {
      my $list = $element;
      $element = { directory => [ @$list ], file => [ @$list ] };
    }
  
    if ( exists $element->{dir} ) {
      $element->{directory} = delete $element->{dir};
    }
    # common mistake: files -> file
    if ( exists $element->{files} ) {
      $element->{file} = delete $element->{files};
    }
    # common mistake: modules -> module
    if ( exists $element->{modules} ) {
      $element->{module} = delete $element->{modules};
    }
    my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
    return _convert($element, $spec);
  }
  
  sub _is_module_name {
    my $mod = shift;
    return unless defined $mod && length $mod;
    return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
  }
  
  sub _clean_version {
    my ($element) = @_;
    return 0 if ! defined $element;
  
    $element =~ s{^\s*}{};
    $element =~ s{\s*$}{};
    $element =~ s{^\.}{0.};
  
    return 0 if ! length $element;
    return 0 if ( $element eq 'undef' || $element eq '<undef>' );
  
    my $v = eval { version->new($element) };
    # XXX check defined $v and not just $v because version objects leak memory
    # in boolean context -- dagolden, 2012-02-03
    if ( defined $v ) {
      return _is_qv($v) ? $v->normal : $element;
    }
    else {
      return 0;
    }
  }
  
  sub _bad_version_hook {
    my ($v) = @_;
    $v =~ s{^\s*}{};
    $v =~ s{\s*$}{};
    $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
    my $vobj = eval { version->new($v) };
    return defined($vobj) ? $vobj : version->new(0); # or give up
  }
  
  sub _version_map {
    my ($element) = @_;
    return unless defined $element;
    if ( ref $element eq 'HASH' ) {
      # XXX turn this into CPAN::Meta::Requirements with bad version hook
      # and then turn it back into a hash
      my $new_map = CPAN::Meta::Requirements->new(
        { bad_version_hook => \&_bad_version_hook } # punt
      );
      while ( my ($k,$v) = each %$element ) {
        next unless _is_module_name($k);
        if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>'  ) {
          $v = 0;
        }
        # some weird, old META have bad yml with module => module
        # so check if value is like a module name and not like a version
        if ( _is_module_name($v) && ! version::is_lax($v) ) {
          $new_map->add_minimum($k => 0);
          $new_map->add_minimum($v => 0);
        }
        $new_map->add_string_requirement($k => $v);
      }
      return $new_map->as_string_hash;
    }
    elsif ( ref $element eq 'ARRAY' ) {
      my $hashref = { map { $_ => 0 } @$element };
      return _version_map($hashref); # clean up any weird stuff
    }
    elsif ( ref $element eq '' && length $element ) {
      return { $element => 0 }
    }
    return;
  }
  
  sub _prereqs_from_1 {
    my (undef, undef, $meta) = @_;
    my $prereqs = {};
    for my $phase ( qw/build configure/ ) {
      my $key = "${phase}_requires";
      $prereqs->{$phase}{requires} = _version_map($meta->{$key})
        if $meta->{$key};
    }
    for my $rel ( qw/requires recommends conflicts/ ) {
      $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
        if $meta->{$rel};
    }
    return $prereqs;
  }
  
  my $prereqs_spec = {
    configure => \&_prereqs_rel,
    build     => \&_prereqs_rel,
    test      => \&_prereqs_rel,
    runtime   => \&_prereqs_rel,
    develop   => \&_prereqs_rel,
    ':custom'  => \&_prefix_custom,
  };
  
  my $relation_spec = {
    requires   => \&_version_map,
    recommends => \&_version_map,
    suggests   => \&_version_map,
    conflicts  => \&_version_map,
    ':custom'  => \&_prefix_custom,
  };
  
  sub _cleanup_prereqs {
    my ($prereqs, $key, $meta, $to_version) = @_;
    return unless $prereqs && ref $prereqs eq 'HASH';
    return _convert( $prereqs, $prereqs_spec, $to_version );
  }
  
  sub _prereqs_rel {
    my ($relation, $key, $meta, $to_version) = @_;
    return unless $relation && ref $relation eq 'HASH';
    return _convert( $relation, $relation_spec, $to_version );
  }
  
  
  BEGIN {
    my @old_prereqs = qw(
      requires
      configure_requires
      recommends
      conflicts
    );
  
    for ( @old_prereqs ) {
      my $sub = "_get_$_";
      my ($phase,$type) = split qr/_/, $_;
      if ( ! defined $type ) {
        $type = $phase;
        $phase = 'runtime';
      }
      no strict 'refs';
      *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
    }
  }
  
  sub _get_build_requires {
    my ($data, $key, $meta) = @_;
  
    my $test_h  = _extract_prereqs($_[2]->{prereqs}, qw(test  requires)) || {};
    my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
  
    my $test_req  = CPAN::Meta::Requirements->from_string_hash($test_h);
    my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
  
    $test_req->add_requirements($build_req)->as_string_hash;
  }
  
  sub _extract_prereqs {
    my ($prereqs, $phase, $type) = @_;
    return unless ref $prereqs eq 'HASH';
    return scalar _version_map($prereqs->{$phase}{$type});
  }
  
  sub _downgrade_optional_features {
    my (undef, undef, $meta) = @_;
    return unless exists $meta->{optional_features};
    my $origin = $meta->{optional_features};
    my $features = {};
    for my $name ( keys %$origin ) {
      $features->{$name} = {
        description => $origin->{$name}{description},
        requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
        configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
        build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
        recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
        conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
      };
      for my $k (keys %{$features->{$name}} ) {
        delete $features->{$name}{$k} unless defined $features->{$name}{$k};
      }
    }
    return $features;
  }
  
  sub _upgrade_optional_features {
    my (undef, undef, $meta) = @_;
    return unless exists $meta->{optional_features};
    my $origin = $meta->{optional_features};
    my $features = {};
    for my $name ( keys %$origin ) {
      $features->{$name} = {
        description => $origin->{$name}{description},
        prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
      };
      delete $features->{$name}{prereqs}{configure};
    }
    return $features;
  }
  
  my $optional_features_2_spec = {
    description => \&_keep,
    prereqs => \&_cleanup_prereqs,
    ':custom'  => \&_prefix_custom,
  };
  
  sub _feature_2 {
    my ($element, $key, $meta, $to_version) = @_;
    return unless $element && ref $element eq 'HASH';
    _convert( $element, $optional_features_2_spec, $to_version );
  }
  
  sub _cleanup_optional_features_2 {
    my ($element, $key, $meta, $to_version) = @_;
    return unless $element && ref $element eq 'HASH';
    my $new_data = {};
    for my $k ( keys %$element ) {
      $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
    }
    return unless keys %$new_data;
    return $new_data;
  }
  
  sub _optional_features_1_4 {
    my ($element) = @_;
    return unless $element;
    $element = _optional_features_as_map($element);
    for my $name ( keys %$element ) {
      for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
        delete $element->{$name}{$drop};
      }
    }
    return $element;
  }
  
  sub _optional_features_as_map {
    my ($element) = @_;
    return unless $element;
    if ( ref $element eq 'ARRAY' ) {
      my %map;
      for my $feature ( @$element ) {
        my (@parts) = %$feature;
        $map{$parts[0]} = $parts[1];
      }
      $element = \%map;
    }
    return $element;
  }
  
  sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
  
  sub _url_or_drop {
    my ($element) = @_;
    return $element if _is_urlish($element);
    return;
  }
  
  sub _url_list {
    my ($element) = @_;
    return unless $element;
    $element = _listify( $element );
    $element = [ grep { _is_urlish($_) } @$element ];
    return unless @$element;
    return $element;
  }
  
  sub _author_list {
    my ($element) = @_;
    return [ 'unknown' ] unless $element;
    $element = _listify( $element );
    $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
    return [ 'unknown' ] unless @$element;
    return $element;
  }
  
  my $resource2_upgrade = {
    license    => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
    homepage   => \&_url_or_drop,
    bugtracker => sub {
      my ($item) = @_;
      return unless $item;
      if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
      elsif( _is_urlish($item) ) { return { web => $item } }
      else { return }
    },
    repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
    ':custom'  => \&_prefix_custom,
  };
  
  sub _upgrade_resources_2 {
    my (undef, undef, $meta, $version) = @_;
    return unless exists $meta->{resources};
    return _convert($meta->{resources}, $resource2_upgrade);
  }
  
  my $bugtracker2_spec = {
    web => \&_url_or_drop,
    mailto => \&_keep,
    ':custom'  => \&_prefix_custom,
  };
  
  sub _repo_type {
    my ($element, $key, $meta, $to_version) = @_;
    return $element if defined $element;
    return unless exists $meta->{url};
    my $repo_url = $meta->{url};
    for my $type ( qw/git svn/ ) {
      return $type if $repo_url =~ m{\A$type};
    }
    return;
  }
  
  my $repository2_spec = {
    web => \&_url_or_drop,
    url => \&_url_or_drop,
    type => \&_repo_type,
    ':custom'  => \&_prefix_custom,
  };
  
  my $resources2_cleanup = {
    license    => \&_url_list,
    homepage   => \&_url_or_drop,
    bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
    repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
    ':custom'  => \&_prefix_custom,
  };
  
  sub _cleanup_resources_2 {
    my ($resources, $key, $meta, $to_version) = @_;
    return unless $resources && ref $resources eq 'HASH';
    return _convert($resources, $resources2_cleanup, $to_version);
  }
  
  my $resource1_spec = {
    license    => \&_url_or_drop,
    homepage   => \&_url_or_drop,
    bugtracker => \&_url_or_drop,
    repository => \&_url_or_drop,
    ':custom'  => \&_keep,
  };
  
  sub _resources_1_3 {
    my (undef, undef, $meta, $version) = @_;
    return unless exists $meta->{resources};
    return _convert($meta->{resources}, $resource1_spec);
  }
  
  *_resources_1_4 = *_resources_1_3;
  
  sub _resources_1_2 {
    my (undef, undef, $meta) = @_;
    my $resources = $meta->{resources} || {};
    if ( $meta->{license_url} && ! $resources->{license} ) {
      $resources->{license} = $meta->{license_url}
        if _is_urlish($meta->{license_url});
    }
    return unless keys %$resources;
    return _convert($resources, $resource1_spec);
  }
  
  my $resource_downgrade_spec = {
    license    => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
    homepage   => \&_url_or_drop,
    bugtracker => sub { return $_[0]->{web} },
    repository => sub { return $_[0]->{url} || $_[0]->{web} },
    ':custom'  => \&_no_prefix_ucfirst_custom,
  };
  
  sub _downgrade_resources {
    my (undef, undef, $meta, $version) = @_;
    return unless exists $meta->{resources};
    return _convert($meta->{resources}, $resource_downgrade_spec);
  }
  
  sub _release_status {
    my ($element, undef, $meta) = @_;
    return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
    return _release_status_from_version(undef, undef, $meta);
  }
  
  sub _release_status_from_version {
    my (undef, undef, $meta) = @_;
    my $version = $meta->{version} || '';
    return ( $version =~ /_/ ) ? 'testing' : 'stable';
  }
  
  my $provides_spec = {
    file => \&_keep,
    version => \&_keep,
  };
  
  my $provides_spec_2 = {
    file => \&_keep,
    version => \&_keep,
    ':custom'  => \&_prefix_custom,
  };
  
  sub _provides {
    my ($element, $key, $meta, $to_version) = @_;
    return unless defined $element && ref $element eq 'HASH';
    my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
    my $new_data = {};
    for my $k ( keys %$element ) {
      $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
      $new_data->{$k}{version} = _clean_version($element->{$k}{version})
        if exists $element->{$k}{version};
    }
    return $new_data;
  }
  
  sub _convert {
    my ($data, $spec, $to_version, $is_fragment) = @_;
  
    my $new_data = {};
    for my $key ( keys %$spec ) {
      next if $key eq ':custom' || $key eq ':drop';
      next unless my $fcn = $spec->{$key};
      if ( $is_fragment && $key eq 'generated_by' ) {
        $fcn = \&_keep;
      }
      die "spec for '$key' is not a coderef"
        unless ref $fcn && ref $fcn eq 'CODE';
      my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
      $new_data->{$key} = $new_value if defined $new_value;
    }
  
    my $drop_list   = $spec->{':drop'};
    my $customizer  = $spec->{':custom'} || \&_keep;
  
    for my $key ( keys %$data ) {
      next if $drop_list && grep { $key eq $_ } @$drop_list;
      next if exists $spec->{$key}; # we handled it
      $new_data->{ $customizer->($key) } = $data->{$key};
    }
  
    return $new_data;
  }
  
  #--------------------------------------------------------------------------#
  # define converters for each conversion
  #--------------------------------------------------------------------------#
  
  # each converts from prior version
  # special ":custom" field is used for keys not recognized in spec
  my %up_convert = (
    '2-from-1.4' => {
      # PRIOR MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_2,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # CHANGED TO MANDATORY
      'dynamic_config'      => \&_keep_or_one,
      # ADDED MANDATORY
      'release_status'      => \&_release_status,
      # PRIOR OPTIONAL
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_upgrade_optional_features,
      'provides'            => \&_provides,
      'resources'           => \&_upgrade_resources_2,
      # ADDED OPTIONAL
      'description'         => \&_keep,
      'prereqs'             => \&_prereqs_from_1,
  
      # drop these deprecated fields, but only after we convert
      ':drop' => [ qw(
          build_requires
          configure_requires
          conflicts
          distribution_type
          license_url
          private
          recommends
          requires
      ) ],
  
      # other random keys need x_ prefixing
      ':custom'              => \&_prefix_custom,
    },
    '1.4-from-1.3' => {
      # PRIOR MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_optional_features_1_4,
      'provides'            => \&_provides,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      'resources'           => \&_resources_1_4,
      # ADDED OPTIONAL
      'configure_requires'  => \&_keep,
  
      # drop these deprecated fields, but only after we convert
      ':drop' => [ qw(
        license_url
        private
      )],
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep
    },
    '1.3-from-1.2' => {
      # PRIOR MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_optional_features_as_map,
      'provides'            => \&_provides,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      'resources'           => \&_resources_1_3,
  
      # drop these deprecated fields, but only after we convert
      ':drop' => [ qw(
        license_url
        private
      )],
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep
    },
    '1.2-from-1.1' => {
      # PRIOR MANDATORY
      'version'             => \&_keep,
      # CHANGED TO MANDATORY
      'license'             => \&_license_1,
      'name'                => \&_keep,
      'generated_by'        => \&_generated_by,
      # ADDED MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'meta-spec'           => \&_change_meta_spec,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      # ADDED OPTIONAL
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_1_2,
      'optional_features'   => \&_optional_features_as_map,
      'provides'            => \&_provides,
      'resources'           => \&_resources_1_2,
  
      # drop these deprecated fields, but only after we convert
      ':drop' => [ qw(
        license_url
        private
      )],
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep
    },
    '1.1-from-1.0' => {
      # CHANGED TO MANDATORY
      'version'             => \&_keep,
      # IMPLIED MANDATORY
      'name'                => \&_keep,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      # ADDED OPTIONAL
      'license_url'         => \&_url_or_drop,
      'private'             => \&_keep,
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep
    },
  );
  
  my %down_convert = (
    '1.4-from-2' => {
      # MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_downgrade_license,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # OPTIONAL
      'build_requires'      => \&_get_build_requires,
      'configure_requires'  => \&_get_configure_requires,
      'conflicts'           => \&_get_conflicts,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_downgrade_optional_features,
      'provides'            => \&_provides,
      'recommends'          => \&_get_recommends,
      'requires'            => \&_get_requires,
      'resources'           => \&_downgrade_resources,
  
      # drop these unsupported fields (after conversion)
      ':drop' => [ qw(
        description
        prereqs
        release_status
      )],
  
      # custom keys will be left unchanged
      ':custom'              => \&_keep
    },
    '1.3-from-1.4' => {
      # MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_optional_features_as_map,
      'provides'            => \&_provides,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      'resources'           => \&_resources_1_3,
  
      # drop these unsupported fields, but only after we convert
      ':drop' => [ qw(
        configure_requires
      )],
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep,
    },
    '1.2-from-1.3' => {
      # MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_1_2,
      'optional_features'   => \&_optional_features_as_map,
      'provides'            => \&_provides,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      'resources'           => \&_resources_1_3,
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep,
    },
    '1.1-from-1.2' => {
      # MANDATORY
      'version'             => \&_keep,
      # IMPLIED MANDATORY
      'name'                => \&_keep,
      'meta-spec'           => \&_change_meta_spec,
      # OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'private'             => \&_keep,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
  
      # drop unsupported fields
      ':drop' => [ qw(
        abstract
        author
        provides
        no_index
        keywords
        resources
      )],
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep,
    },
    '1.0-from-1.1' => {
      # IMPLIED MANDATORY
      'name'                => \&_keep,
      'meta-spec'           => \&_change_meta_spec,
      'version'             => \&_keep,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
  
      # other random keys are OK if already valid
      ':custom'              => \&_keep,
    },
  );
  
  my %cleanup = (
    '2' => {
      # PRIOR MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_2,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # CHANGED TO MANDATORY
      'dynamic_config'      => \&_keep_or_one,
      # ADDED MANDATORY
      'release_status'      => \&_release_status,
      # PRIOR OPTIONAL
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_cleanup_optional_features_2,
      'provides'            => \&_provides,
      'resources'           => \&_cleanup_resources_2,
      # ADDED OPTIONAL
      'description'         => \&_keep,
      'prereqs'             => \&_cleanup_prereqs,
  
      # drop these deprecated fields, but only after we convert
      ':drop' => [ qw(
          build_requires
          configure_requires
          conflicts
          distribution_type
          license_url
          private
          recommends
          requires
      ) ],
  
      # other random keys need x_ prefixing
      ':custom'              => \&_prefix_custom,
    },
    '1.4' => {
      # PRIOR MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_optional_features_1_4,
      'provides'            => \&_provides,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      'resources'           => \&_resources_1_4,
      # ADDED OPTIONAL
      'configure_requires'  => \&_keep,
  
      # other random keys are OK if already valid
      ':custom'             => \&_keep
    },
    '1.3' => {
      # PRIOR MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'meta-spec'           => \&_change_meta_spec,
      'name'                => \&_keep,
      'version'             => \&_keep,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_directory,
      'optional_features'   => \&_optional_features_as_map,
      'provides'            => \&_provides,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      'resources'           => \&_resources_1_3,
  
      # other random keys are OK if already valid
      ':custom'             => \&_keep
    },
    '1.2' => {
      # PRIOR MANDATORY
      'version'             => \&_keep,
      # CHANGED TO MANDATORY
      'license'             => \&_license_1,
      'name'                => \&_keep,
      'generated_by'        => \&_generated_by,
      # ADDED MANDATORY
      'abstract'            => \&_keep_or_unknown,
      'author'              => \&_author_list,
      'meta-spec'           => \&_change_meta_spec,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      # ADDED OPTIONAL
      'keywords'            => \&_keep,
      'no_index'            => \&_no_index_1_2,
      'optional_features'   => \&_optional_features_as_map,
      'provides'            => \&_provides,
      'resources'           => \&_resources_1_2,
  
      # other random keys are OK if already valid
      ':custom'             => \&_keep
    },
    '1.1' => {
      # CHANGED TO MANDATORY
      'version'             => \&_keep,
      # IMPLIED MANDATORY
      'name'                => \&_keep,
      'meta-spec'           => \&_change_meta_spec,
      # PRIOR OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
      # ADDED OPTIONAL
      'license_url'         => \&_url_or_drop,
      'private'             => \&_keep,
  
      # other random keys are OK if already valid
      ':custom'             => \&_keep
    },
    '1.0' => {
      # IMPLIED MANDATORY
      'name'                => \&_keep,
      'meta-spec'           => \&_change_meta_spec,
      'version'             => \&_keep,
      # IMPLIED OPTIONAL
      'build_requires'      => \&_version_map,
      'conflicts'           => \&_version_map,
      'distribution_type'   => \&_keep,
      'dynamic_config'      => \&_keep_or_one,
      'generated_by'        => \&_generated_by,
      'license'             => \&_license_1,
      'recommends'          => \&_version_map,
      'requires'            => \&_version_map,
  
      # other random keys are OK if already valid
      ':custom'             => \&_keep,
    },
  );
  
  # for a given field in a spec version, what fields will it feed
  # into in the *latest* spec (i.e. v2); meta-spec omitted because
  # we always expect a meta-spec to be generated
  my %fragments_generate = (
    '2' => {
      'abstract'            =>   'abstract',
      'author'              =>   'author',
      'generated_by'        =>   'generated_by',
      'license'             =>   'license',
      'name'                =>   'name',
      'version'             =>   'version',
      'dynamic_config'      =>   'dynamic_config',
      'release_status'      =>   'release_status',
      'keywords'            =>   'keywords',
      'no_index'            =>   'no_index',
      'optional_features'   =>   'optional_features',
      'provides'            =>   'provides',
      'resources'           =>   'resources',
      'description'         =>   'description',
      'prereqs'             =>   'prereqs',
    },
    '1.4' => {
      'abstract'            => 'abstract',
      'author'              => 'author',
      'generated_by'        => 'generated_by',
      'license'             => 'license',
      'name'                => 'name',
      'version'             => 'version',
      'build_requires'      => 'prereqs',
      'conflicts'           => 'prereqs',
      'distribution_type'   => 'distribution_type',
      'dynamic_config'      => 'dynamic_config',
      'keywords'            => 'keywords',
      'no_index'            => 'no_index',
      'optional_features'   => 'optional_features',
      'provides'            => 'provides',
      'recommends'          => 'prereqs',
      'requires'            => 'prereqs',
      'resources'           => 'resources',
      'configure_requires'  => 'prereqs',
    },
  );
  # this is not quite true but will work well enough
  # as 1.4 is a superset of earlier ones
  $fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
  
  #--------------------------------------------------------------------------#
  # Code
  #--------------------------------------------------------------------------#
  
  #pod =method new
  #pod
  #pod   my $cmc = CPAN::Meta::Converter->new( $struct );
  #pod
  #pod The constructor should be passed a valid metadata structure but invalid
  #pod structures are accepted.  If no meta-spec version is provided, version 1.0 will
  #pod be assumed.
  #pod
  #pod Optionally, you can provide a C<default_version> argument after C<$struct>:
  #pod
  #pod   my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
  #pod
  #pod This is only needed when converting a metadata fragment that does not include a
  #pod C<meta-spec> field.
  #pod
  #pod =cut
  
  sub new {
    my ($class,$data,%args) = @_;
  
    # create an attributes hash
    my $self = {
      'data'    => $data,
      'spec'    => _extract_spec_version($data, $args{default_version}),
    };
  
    # create the object
    return bless $self, $class;
  }
  
  sub _extract_spec_version {
      my ($data, $default) = @_;
      my $spec = $data->{'meta-spec'};
  
      # is meta-spec there and valid?
      return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
  
      # does the version key look like a valid version?
      my $v = $spec->{version};
      if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
          return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
          return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
      }
  
      # otherwise, use heuristics: look for 1.x vs 2.0 fields
      return "2" if exists $data->{prereqs};
      return "1.4" if exists $data->{configure_requires};
      return( $default || "1.2" ); # when meta-spec was first defined
  }
  
  #pod =method convert
  #pod
  #pod   my $new_struct = $cmc->convert( version => "2" );
  #pod
  #pod Returns a new hash reference with the metadata converted to a different form.
  #pod C<convert> will die if any conversion/standardization still results in an
  #pod invalid structure.
  #pod
  #pod Valid parameters include:
  #pod
  #pod =over
  #pod
  #pod =item *
  #pod
  #pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
  #pod Defaults to the latest version of the CPAN Meta Spec.
  #pod
  #pod =back
  #pod
  #pod Conversion proceeds through each version in turn.  For example, a version 1.2
  #pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
  #pod conversion process attempts to clean-up simple errors and standardize data.
  #pod For example, if C<author> is given as a scalar, it will converted to an array
  #pod reference containing the item. (Converting a structure to its own version will
  #pod also clean-up and standardize.)
  #pod
  #pod When data are cleaned and standardized, missing or invalid fields will be
  #pod replaced with sensible defaults when possible.  This may be lossy or imprecise.
  #pod For example, some badly structured META.yml files on CPAN have prerequisite
  #pod modules listed as both keys and values:
  #pod
  #pod   requires => { 'Foo::Bar' => 'Bam::Baz' }
  #pod
  #pod These would be split and each converted to a prerequisite with a minimum
  #pod version of zero.
  #pod
  #pod When some mandatory fields are missing or invalid, the conversion will attempt
  #pod to provide a sensible default or will fill them with a value of 'unknown'.  For
  #pod example a missing or unrecognized C<license> field will result in a C<license>
  #pod field of 'unknown'.  Fields that may get an 'unknown' include:
  #pod
  #pod =for :list
  #pod * abstract
  #pod * author
  #pod * license
  #pod
  #pod =cut
  
  sub convert {
    my ($self, %args) = @_;
    my $args = { %args };
  
    my $new_version = $args->{version} || $HIGHEST;
    my $is_fragment = $args->{is_fragment};
  
    my ($old_version) = $self->{spec};
    my $converted = _dclone($self->{data});
  
    if ( $old_version == $new_version ) {
      $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
      unless ( $args->{is_fragment} ) {
        my $cmv = CPAN::Meta::Validator->new( $converted );
        unless ( $cmv->is_valid ) {
          my $errs = join("\n", $cmv->errors);
          die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
        }
      }
      return $converted;
    }
    elsif ( $old_version > $new_version )  {
      my @vers = sort { $b <=> $a } keys %known_specs;
      for my $i ( 0 .. $#vers-1 ) {
        next if $vers[$i] > $old_version;
        last if $vers[$i+1] < $new_version;
        my $spec_string = "$vers[$i+1]-from-$vers[$i]";
        $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
        unless ( $args->{is_fragment} ) {
          my $cmv = CPAN::Meta::Validator->new( $converted );
          unless ( $cmv->is_valid ) {
            my $errs = join("\n", $cmv->errors);
            die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
          }
        }
      }
      return $converted;
    }
    else {
      my @vers = sort { $a <=> $b } keys %known_specs;
      for my $i ( 0 .. $#vers-1 ) {
        next if $vers[$i] < $old_version;
        last if $vers[$i+1] > $new_version;
        my $spec_string = "$vers[$i+1]-from-$vers[$i]";
        $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
        unless ( $args->{is_fragment} ) {
          my $cmv = CPAN::Meta::Validator->new( $converted );
          unless ( $cmv->is_valid ) {
            my $errs = join("\n", $cmv->errors);
            die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
          }
        }
      }
      return $converted;
    }
  }
  
  #pod =method upgrade_fragment
  #pod
  #pod   my $new_struct = $cmc->upgrade_fragment;
  #pod
  #pod Returns a new hash reference with the metadata converted to the latest version
  #pod of the CPAN Meta Spec.  No validation is done on the result -- you must
  #pod validate after merging fragments into a complete metadata document.
  #pod
  #pod Available since version 2.141170.
  #pod
  #pod =cut
  
  sub upgrade_fragment {
    my ($self) = @_;
    my ($old_version) = $self->{spec};
    my %expected =
      map {; $_ => 1 }
      grep { defined }
      map { $fragments_generate{$old_version}{$_} }
      keys %{ $self->{data} };
    my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
    for my $key ( keys %$converted ) {
      next if $key =~ /^x_/i || $key eq 'meta-spec';
      delete $converted->{$key} unless $expected{$key};
    }
    return $converted;
  }
  
  1;
  
  # ABSTRACT: Convert CPAN distribution metadata structures
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Converter - Convert CPAN distribution metadata structures
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 SYNOPSIS
  
    my $struct = decode_json_file('META.json');
  
    my $cmc = CPAN::Meta::Converter->new( $struct );
  
    my $new_struct = $cmc->convert( version => "2" );
  
  =head1 DESCRIPTION
  
  This module converts CPAN Meta structures from one form to another.  The
  primary use is to convert older structures to the most modern version of
  the specification, but other transformations may be implemented in the
  future as needed.  (E.g. stripping all custom fields or stripping all
  optional fields.)
  
  =head1 METHODS
  
  =head2 new
  
    my $cmc = CPAN::Meta::Converter->new( $struct );
  
  The constructor should be passed a valid metadata structure but invalid
  structures are accepted.  If no meta-spec version is provided, version 1.0 will
  be assumed.
  
  Optionally, you can provide a C<default_version> argument after C<$struct>:
  
    my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
  
  This is only needed when converting a metadata fragment that does not include a
  C<meta-spec> field.
  
  =head2 convert
  
    my $new_struct = $cmc->convert( version => "2" );
  
  Returns a new hash reference with the metadata converted to a different form.
  C<convert> will die if any conversion/standardization still results in an
  invalid structure.
  
  Valid parameters include:
  
  =over
  
  =item *
  
  C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
  Defaults to the latest version of the CPAN Meta Spec.
  
  =back
  
  Conversion proceeds through each version in turn.  For example, a version 1.2
  structure might be converted to 1.3 then 1.4 then finally to version 2. The
  conversion process attempts to clean-up simple errors and standardize data.
  For example, if C<author> is given as a scalar, it will converted to an array
  reference containing the item. (Converting a structure to its own version will
  also clean-up and standardize.)
  
  When data are cleaned and standardized, missing or invalid fields will be
  replaced with sensible defaults when possible.  This may be lossy or imprecise.
  For example, some badly structured META.yml files on CPAN have prerequisite
  modules listed as both keys and values:
  
    requires => { 'Foo::Bar' => 'Bam::Baz' }
  
  These would be split and each converted to a prerequisite with a minimum
  version of zero.
  
  When some mandatory fields are missing or invalid, the conversion will attempt
  to provide a sensible default or will fill them with a value of 'unknown'.  For
  example a missing or unrecognized C<license> field will result in a C<license>
  field of 'unknown'.  Fields that may get an 'unknown' include:
  
  =over 4
  
  =item *
  
  abstract
  
  =item *
  
  author
  
  =item *
  
  license
  
  =back
  
  =head2 upgrade_fragment
  
    my $new_struct = $cmc->upgrade_fragment;
  
  Returns a new hash reference with the metadata converted to the latest version
  of the CPAN Meta Spec.  No validation is done on the result -- you must
  validate after merging fragments into a complete metadata document.
  
  Available since version 2.141170.
  
  =head1 BUGS
  
  Please report any bugs or feature using the CPAN Request Tracker.
  Bugs can be submitted through the web interface at
  L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
  
  When submitting a bug or request, please include a test-file or a patch to an
  existing test-file that illustrates the bug or desired feature.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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
  
  __END__
  
  
  # vim: ts=2 sts=2 sw=2 et :
CPAN_META_CONVERTER

$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE';
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta::Feature;
  
  our $VERSION = '2.150010';
  
  use CPAN::Meta::Prereqs;
  
  #pod =head1 DESCRIPTION
  #pod
  #pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
  #pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
  #pod file.
  #pod
  #pod For the most part, this class will only be used when operating on the result of
  #pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
  #pod
  #pod =method new
  #pod
  #pod   my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
  #pod
  #pod This returns a new Feature object.  The C<%spec> argument to the constructor
  #pod should be the same as the value of the C<optional_feature> entry in the
  #pod distmeta.  It must contain entries for C<description> and C<prereqs>.
  #pod
  #pod =cut
  
  sub new {
    my ($class, $identifier, $spec) = @_;
  
    my %guts = (
      identifier  => $identifier,
      description => $spec->{description},
      prereqs     => CPAN::Meta::Prereqs->new($spec->{prereqs}),
    );
  
    bless \%guts => $class;
  }
  
  #pod =method identifier
  #pod
  #pod This method returns the feature's identifier.
  #pod
  #pod =cut
  
  sub identifier  { $_[0]{identifier}  }
  
  #pod =method description
  #pod
  #pod This method returns the feature's long description.
  #pod
  #pod =cut
  
  sub description { $_[0]{description} }
  
  #pod =method prereqs
  #pod
  #pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
  #pod object.
  #pod
  #pod =cut
  
  sub prereqs     { $_[0]{prereqs} }
  
  1;
  
  # ABSTRACT: an optional feature provided by a CPAN distribution
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 DESCRIPTION
  
  A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
  distribution and specified in the distribution's F<META.json> (or F<META.yml>)
  file.
  
  For the most part, this class will only be used when operating on the result of
  the C<feature> or C<features> methods on a L<CPAN::Meta> object.
  
  =head1 METHODS
  
  =head2 new
  
    my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
  
  This returns a new Feature object.  The C<%spec> argument to the constructor
  should be the same as the value of the C<optional_feature> entry in the
  distmeta.  It must contain entries for C<description> and C<prereqs>.
  
  =head2 identifier
  
  This method returns the feature's identifier.
  
  =head2 description
  
  This method returns the feature's long description.
  
  =head2 prereqs
  
  This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
  object.
  
  =head1 BUGS
  
  Please report any bugs or feature using the CPAN Request Tracker.
  Bugs can be submitted through the web interface at
  L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
  
  When submitting a bug or request, please include a test-file or a patch to an
  existing test-file that illustrates the bug or desired feature.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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
  
  __END__
  
  
  # vim: ts=2 sts=2 sw=2 et :
CPAN_META_FEATURE

$fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY';
  # vi:tw=72
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta::History;
  
  our $VERSION = '2.150010';
  
  1;
  
  # ABSTRACT: history of CPAN Meta Spec changes
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::History - history of CPAN Meta Spec changes
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 DESCRIPTION
  
  The CPAN Meta Spec has gone through several iterations.  It was
  originally written in HTML and later revised into POD (though published
  in HTML generated from the POD).  Fields were added, removed or changed,
  sometimes by design and sometimes to reflect real-world usage after the
  fact.
  
  This document reconstructs the history of the CPAN Meta Spec based on
  change logs, repository commit messages and the published HTML files.
  In some cases, particularly prior to version 1.2, the exact version
  when certain fields were introduced or changed is inconsistent between
  sources.  When in doubt, the published HTML files for versions 1.0 to
  1.4 as they existed when version 2 was developed are used as the
  definitive source.
  
  Starting with version 2, the specification document is part of the
  CPAN-Meta distribution and will be published on CPAN as
  L<CPAN::Meta::Spec>.
  
  Going forward, specification version numbers will be integers and
  decimal portions will correspond to a release date for the CPAN::Meta
  library.
  
  =head1 HISTORY
  
  =head2 Version 2
  
  April 2010
  
  =over
  
  =item *
  
  Revised spec examples as perl data structures rather than YAML
  
  =item *
  
  Switched to JSON serialization from YAML
  
  =item *
  
  Specified allowed version number formats
  
  =item *
  
  Replaced 'requires', 'build_requires', 'configure_requires',
  'recommends' and 'conflicts' with new 'prereqs' data structure divided
  by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
  (requires, recommends, suggests, conflicts)
  
  =item *
  
  Added support for 'develop' phase for requirements for maintaining
  a list of authoring tools
  
  =item *
  
  Changed 'license' to a list and revised the set of valid licenses
  
  =item *
  
  Made 'dynamic_config' mandatory to reduce confusion
  
  =item *
  
  Changed 'resources' subkey 'repository' to a hash that clarifies
  repository type, url for browsing and url for checkout
  
  =item *
  
  Changed 'resources' subkey 'bugtracker' to a hash for either web
  or mailto resource
  
  =item *
  
  Changed specification of 'optional_features':
  
  =over
  
  =item *
  
  Added formal specification and usage guide instead of just example
  
  =item *
  
  Changed to use new prereqs data structure instead of individual keys
  
  =back
  
  =item *
  
  Clarified intended use of 'author' as generalized contact list
  
  =item *
  
  Added 'release_status' field to indicate stable, testing or unstable
  status to provide hints to indexers
  
  =item *
  
  Added 'description' field for a longer description of the distribution
  
  =item *
  
  Formalized use of "x_" or "X_" for all custom keys not listed in the
  official spec
  
  =back
  
  =head2 Version 1.4
  
  June 2008
  
  =over
  
  =item *
  
  Noted explicit support for 'perl' in prerequisites
  
  =item *
  
  Added 'configure_requires' prerequisite type
  
  =item *
  
  Changed 'optional_features'
  
  =over
  
  =item *
  
  Example corrected to show map of maps instead of list of maps
  (though descriptive text said 'map' even in v1.3)
  
  =item *
  
  Removed 'requires_packages', 'requires_os' and 'excluded_os'
  as valid subkeys
  
  =back
  
  =back
  
  =head2 Version 1.3
  
  November 2006
  
  =over
  
  =item *
  
  Added 'no_index' subkey 'directory' and removed 'dir' to match actual
  usage in the wild
  
  =item *
  
  Added a 'repository' subkey to 'resources'
  
  =back
  
  =head2 Version 1.2
  
  August 2005
  
  =over
  
  =item *
  
  Re-wrote and restructured spec in POD syntax
  
  =item *
  
  Changed 'name' to be mandatory
  
  =item *
  
  Changed 'generated_by' to be mandatory
  
  =item *
  
  Changed 'license' to be mandatory
  
  =item *
  
  Added version range specifications for prerequisites
  
  =item *
  
  Added required 'abstract' field
  
  =item *
  
  Added required 'author' field
  
  =item *
  
  Added required 'meta-spec' field to define 'version' (and 'url') of the
  CPAN Meta Spec used for metadata
  
  =item *
  
  Added 'provides' field
  
  =item *
  
  Added 'no_index' field and deprecated 'private' field.  'no_index'
  subkeys include 'file', 'dir', 'package' and 'namespace'
  
  =item *
  
  Added 'keywords' field
  
  =item *
  
  Added 'resources' field with subkeys 'homepage', 'license', and
  'bugtracker'
  
  =item *
  
  Added 'optional_features' field as an alternate under 'recommends'.
  Includes 'description', 'requires', 'build_requires', 'conflicts',
  'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
  
  =item *
  
  Removed 'license_uri' field
  
  =back
  
  =head2 Version 1.1
  
  May 2003
  
  =over
  
  =item *
  
  Changed 'version' to be mandatory
  
  =item *
  
  Added 'private' field
  
  =item *
  
  Added 'license_uri' field
  
  =back
  
  =head2 Version 1.0
  
  March 2003
  
  =over
  
  =item *
  
  Original release (in HTML format only)
  
  =item *
  
  Included 'name', 'version', 'license', 'distribution_type', 'requires',
  'recommends', 'build_requires', 'conflicts', 'dynamic_config',
  'generated_by'
  
  =back
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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_META_HISTORY

$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE';
  use strict;
  use warnings;
  
  package CPAN::Meta::Merge;
  
  our $VERSION = '2.150010';
  
  use Carp qw/croak/;
  use Scalar::Util qw/blessed/;
  use CPAN::Meta::Converter 2.141170;
  
  sub _is_identical {
    my ($left, $right) = @_;
    return
      (not defined $left and not defined $right)
      # if either of these are references, we compare the serialized value
      || (defined $left and defined $right and $left eq $right);
  }
  
  sub _identical {
    my ($left, $right, $path) = @_;
    croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
      unless _is_identical($left, $right);
    return $left;
  }
  
  sub _merge {
    my ($current, $next, $mergers, $path) = @_;
    for my $key (keys %{$next}) {
      if (not exists $current->{$key}) {
        $current->{$key} = $next->{$key};
      }
      elsif (my $merger = $mergers->{$key}) {
        $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
      }
      elsif ($merger = $mergers->{':default'}) {
        $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
      }
      else {
        croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
      }
    }
    return $current;
  }
  
  sub _uniq {
    my %seen = ();
    return grep { not $seen{$_}++ } @_;
  }
  
  sub _set_addition {
    my ($left, $right) = @_;
    return [ +_uniq(@{$left}, @{$right}) ];
  }
  
  sub _uniq_map {
    my ($left, $right, $path) = @_;
    for my $key (keys %{$right}) {
      if (not exists $left->{$key}) {
        $left->{$key} = $right->{$key};
      }
      # identical strings or references are merged identically
      elsif (_is_identical($left->{$key}, $right->{$key})) {
        1; # do nothing - keep left
      }
      elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
        $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
      }
      else {
        croak 'Duplication of element ' . join '.', @{$path}, $key;
      }
    }
    return $left;
  }
  
  sub _improvise {
    my ($left, $right, $path) = @_;
    my ($name) = reverse @{$path};
    if ($name =~ /^x_/) {
      if (ref($left) eq 'ARRAY') {
        return _set_addition($left, $right, $path);
      }
      elsif (ref($left) eq 'HASH') {
        return _uniq_map($left, $right, $path);
      }
      else {
        return _identical($left, $right, $path);
      }
    }
    croak sprintf "Can't merge '%s'", join '.', @{$path};
  }
  
  sub _optional_features {
    my ($left, $right, $path) = @_;
  
    for my $key (keys %{$right}) {
      if (not exists $left->{$key}) {
        $left->{$key} = $right->{$key};
      }
      else {
        for my $subkey (keys %{ $right->{$key} }) {
          next if $subkey eq 'prereqs';
          if (not exists $left->{$key}{$subkey}) {
            $left->{$key}{$subkey} = $right->{$key}{$subkey};
          }
          else {
            Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
              if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
          }
        }
  
        require CPAN::Meta::Prereqs;
        $left->{$key}{prereqs} =
          CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
            ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
            ->as_string_hash;
      }
    }
    return $left;
  }
  
  
  my %default = (
    abstract       => \&_identical,
    author         => \&_set_addition,
    dynamic_config => sub {
      my ($left, $right) = @_;
      return $left || $right;
    },
    generated_by => sub {
      my ($left, $right) = @_;
      return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
    },
    license     => \&_set_addition,
    'meta-spec' => {
      version => \&_identical,
      url     => \&_identical
    },
    name              => \&_identical,
    release_status    => \&_identical,
    version           => \&_identical,
    description       => \&_identical,
    keywords          => \&_set_addition,
    no_index          => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
    optional_features => \&_optional_features,
    prereqs           => sub {
      require CPAN::Meta::Prereqs;
      my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
      return $left->with_merged_prereqs($right)->as_string_hash;
    },
    provides  => \&_uniq_map,
    resources => {
      license    => \&_set_addition,
      homepage   => \&_identical,
      bugtracker => \&_uniq_map,
      repository => \&_uniq_map,
      ':default' => \&_improvise,
    },
    ':default' => \&_improvise,
  );
  
  sub new {
    my ($class, %arguments) = @_;
    croak 'default version required' if not exists $arguments{default_version};
    my %mapping = %default;
    my %extra = %{ $arguments{extra_mappings} || {} };
    for my $key (keys %extra) {
      if (ref($mapping{$key}) eq 'HASH') {
        $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
      }
      else {
        $mapping{$key} = $extra{$key};
      }
    }
    return bless {
      default_version => $arguments{default_version},
      mapping => _coerce_mapping(\%mapping, []),
    }, $class;
  }
  
  my %coderef_for = (
    set_addition => \&_set_addition,
    uniq_map     => \&_uniq_map,
    identical    => \&_identical,
    improvise    => \&_improvise,
    improvize    => \&_improvise, # [sic] for backwards compatibility
  );
  
  sub _coerce_mapping {
    my ($orig, $map_path) = @_;
    my %ret;
    for my $key (keys %{$orig}) {
      my $value = $orig->{$key};
      if (ref($orig->{$key}) eq 'CODE') {
        $ret{$key} = $value;
      }
      elsif (ref($value) eq 'HASH') {
        my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
        $ret{$key} = sub {
          my ($left, $right, $path) = @_;
          return _merge($left, $right, $mapping, [ @{$path} ]);
        };
      }
      elsif ($coderef_for{$value}) {
        $ret{$key} = $coderef_for{$value};
      }
      else {
        croak "Don't know what to do with " . join '.', @{$map_path}, $key;
      }
    }
    return \%ret;
  }
  
  sub merge {
    my ($self, @items) = @_;
    my $current = {};
    for my $next (@items) {
      if ( blessed($next) && $next->isa('CPAN::Meta') ) {
        $next = $next->as_struct;
      }
      elsif ( ref($next) eq 'HASH' ) {
        my $cmc = CPAN::Meta::Converter->new(
          $next, default_version => $self->{default_version}
        );
        $next = $cmc->upgrade_fragment;
      }
      else {
        croak "Don't know how to merge '$next'";
      }
      $current = _merge($current, $next, $self->{mapping}, []);
    }
    return $current;
  }
  
  1;
  
  # ABSTRACT: Merging CPAN Meta fragments
  
  
  # vim: ts=2 sts=2 sw=2 et :
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Merge - Merging CPAN Meta fragments
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 SYNOPSIS
  
   my $merger = CPAN::Meta::Merge->new(default_version => "2");
   my $meta = $merger->merge($base, @additional);
  
  =head1 DESCRIPTION
  
  =head1 METHODS
  
  =head2 new
  
  This creates a CPAN::Meta::Merge object. It takes one mandatory named
  argument, C<version>, declaring the version of the meta-spec that must be
  used for the merge. It can optionally take an C<extra_mappings> argument
  that allows one to add additional merging functions for specific elements.
  
  The C<extra_mappings> arguments takes a hash ref with the same type of
  structure as described in L<CPAN::Meta::Spec>, except with its values as
  one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
  to a merging function.
  
    my $merger = CPAN::Meta::Merge->new(
        default_version => '2',
        extra_mappings => {
            'optional_features' => \&custom_merge_function,
            'x_custom' => 'set_addition',
            'x_meta_meta' => {
                name => 'identical',
                tags => 'set_addition',
            }
        }
    );
  
  =head2 merge(@fragments)
  
  Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
  (possibly incomplete) hashrefs of metadata.
  
  =head1 MERGE STRATEGIES
  
  C<merge> uses various strategies to combine different elements of the CPAN::Meta objects.  The following strategies can be used with the extra_mappings argument of C<new>:
  
  =over
  
  =item identical
  
  The elements must be identical
  
  =item set_addition
  
  The union of two array refs
  
    [ a, b ] U [ a, c]  = [ a, b, c ]
  
  =item uniq_map
  
  Key value pairs from the right hash are merged to the left hash.  Key
  collisions are only allowed if their values are the same.  This merge
  function will recurse into nested hash refs following the same merge
  rules.
  
  =item improvise
  
  This merge strategy will try to pick the appropriate predefined strategy
  based on what element type.  Array refs will try to use the
  C<set_addition> strategy,  Hash refs will try to use the C<uniq_map>
  strategy, and everything else will try the C<identical> strategy.
  
  =back
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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_META_MERGE

$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS';
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta::Prereqs;
  
  our $VERSION = '2.150010';
  
  #pod =head1 DESCRIPTION
  #pod
  #pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
  #pod distribution or one of its optional features.  Each set of prereqs is
  #pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
  #pod
  #pod =cut
  
  use Carp qw(confess);
  use Scalar::Util qw(blessed);
  use CPAN::Meta::Requirements 2.121;
  
  #pod =method new
  #pod
  #pod   my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
  #pod
  #pod This method returns a new set of Prereqs.  The input should look like the
  #pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
  #pod something more or less like this:
  #pod
  #pod   my $prereq = CPAN::Meta::Prereqs->new({
  #pod     runtime => {
  #pod       requires => {
  #pod         'Some::Module' => '1.234',
  #pod         ...,
  #pod       },
  #pod       ...,
  #pod     },
  #pod     ...,
  #pod   });
  #pod
  #pod You can also construct an empty set of prereqs with:
  #pod
  #pod   my $prereqs = CPAN::Meta::Prereqs->new;
  #pod
  #pod This empty set of prereqs is useful for accumulating new prereqs before finally
  #pod dumping the whole set into a structure or string.
  #pod
  #pod =cut
  
  # note we also accept anything matching /\Ax_/i
  sub __legal_phases { qw(configure build test runtime develop)   }
  sub __legal_types  { qw(requires recommends suggests conflicts) }
  
  # expect a prereq spec from META.json -- rjbs, 2010-04-11
  sub new {
    my ($class, $prereq_spec) = @_;
    $prereq_spec ||= {};
  
    my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
    my %is_legal_type  = map {; $_ => 1 } $class->__legal_types;
  
    my %guts;
    PHASE: for my $phase (keys %$prereq_spec) {
      next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
  
      my $phase_spec = $prereq_spec->{ $phase };
      next PHASE unless keys %$phase_spec;
  
      TYPE: for my $type (keys %$phase_spec) {
        next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
  
        my $spec = $phase_spec->{ $type };
  
        next TYPE unless keys %$spec;
  
        $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
          $spec
        );
      }
    }
  
    return bless \%guts => $class;
  }
  
  #pod =method requirements_for
  #pod
  #pod   my $requirements = $prereqs->requirements_for( $phase, $type );
  #pod
  #pod This method returns a L<CPAN::Meta::Requirements> object for the given
  #pod phase/type combination.  If no prerequisites are registered for that
  #pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
  #pod be added to as needed.
  #pod
  #pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
  #pod be raised.
  #pod
  #pod =cut
  
  sub requirements_for {
    my ($self, $phase, $type) = @_;
  
    confess "requirements_for called without phase" unless defined $phase;
    confess "requirements_for called without type"  unless defined $type;
  
    unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
      confess "requested requirements for unknown phase: $phase";
    }
  
    unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
      confess "requested requirements for unknown type: $type";
    }
  
    my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
  
    $req->finalize if $self->is_finalized;
  
    return $req;
  }
  
  #pod =method phases
  #pod
  #pod   my @phases = $prereqs->phases;
  #pod
  #pod This method returns the list of all phases currently populated in the prereqs
  #pod object, suitable for iterating.
  #pod
  #pod =cut
  
  sub phases {
    my ($self) = @_;
  
    my %is_legal_phase = map {; $_ => 1 } $self->__legal_phases;
    grep { /\Ax_/i or $is_legal_phase{$_} } keys %{ $self->{prereqs} };
  }
  
  #pod =method types_in
  #pod
  #pod   my @runtime_types = $prereqs->types_in('runtime');
  #pod
  #pod This method returns the list of all types currently populated in the prereqs
  #pod object for the provided phase, suitable for iterating.
  #pod
  #pod =cut
  
  sub types_in {
    my ($self, $phase) = @_;
  
    return unless $phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases;
  
    my %is_legal_type  = map {; $_ => 1 } $self->__legal_types;
    grep { /\Ax_/i or $is_legal_type{$_} } keys %{ $self->{prereqs}{$phase} };
  }
  
  #pod =method with_merged_prereqs
  #pod
  #pod   my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
  #pod
  #pod   my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
  #pod
  #pod This method returns a new CPAN::Meta::Prereqs objects in which all the
  #pod other prerequisites given are merged into the current set.  This is primarily
  #pod provided for combining a distribution's core prereqs with the prereqs of one of
  #pod its optional features.
  #pod
  #pod The new prereqs object has no ties to the originals, and altering it further
  #pod will not alter them.
  #pod
  #pod =cut
  
  sub with_merged_prereqs {
    my ($self, $other) = @_;
  
    my @other = blessed($other) ? $other : @$other;
  
    my @prereq_objs = ($self, @other);
  
    my %new_arg;
  
    for my $phase (__uniq(map { $_->phases } @prereq_objs)) {
      for my $type (__uniq(map { $_->types_in($phase) } @prereq_objs)) {
  
        my $req = CPAN::Meta::Requirements->new;
  
        for my $prereq (@prereq_objs) {
          my $this_req = $prereq->requirements_for($phase, $type);
          next unless $this_req->required_modules;
  
          $req->add_requirements($this_req);
        }
  
        next unless $req->required_modules;
  
        $new_arg{ $phase }{ $type } = $req->as_string_hash;
      }
    }
  
    return (ref $self)->new(\%new_arg);
  }
  
  #pod =method merged_requirements
  #pod
  #pod     my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
  #pod     my $new_reqs = $prereqs->merged_requirements( \@phases );
  #pod     my $new_reqs = $prereqs->merged_requirements();
  #pod
  #pod This method joins together all requirements across a number of phases
  #pod and types into a new L<CPAN::Meta::Requirements> object.  If arguments
  #pod are omitted, it defaults to "runtime", "build" and "test" for phases
  #pod and "requires" and "recommends" for types.
  #pod
  #pod =cut
  
  sub merged_requirements {
    my ($self, $phases, $types) = @_;
    $phases = [qw/runtime build test/] unless defined $phases;
    $types = [qw/requires recommends/] unless defined $types;
  
    confess "merged_requirements phases argument must be an arrayref"
      unless ref $phases eq 'ARRAY';
    confess "merged_requirements types argument must be an arrayref"
      unless ref $types eq 'ARRAY';
  
    my $req = CPAN::Meta::Requirements->new;
  
    for my $phase ( @$phases ) {
      unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
          confess "requested requirements for unknown phase: $phase";
      }
      for my $type ( @$types ) {
        unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
            confess "requested requirements for unknown type: $type";
        }
        $req->add_requirements( $self->requirements_for($phase, $type) );
      }
    }
  
    $req->finalize if $self->is_finalized;
  
    return $req;
  }
  
  
  #pod =method as_string_hash
  #pod
  #pod This method returns a hashref containing structures suitable for dumping into a
  #pod distmeta data structure.  It is made up of hashes and strings, only; there will
  #pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
  #pod
  #pod =cut
  
  sub as_string_hash {
    my ($self) = @_;
  
    my %hash;
  
    for my $phase ($self->phases) {
      for my $type ($self->types_in($phase)) {
        my $req = $self->requirements_for($phase, $type);
        next unless $req->required_modules;
  
        $hash{ $phase }{ $type } = $req->as_string_hash;
      }
    }
  
    return \%hash;
  }
  
  #pod =method is_finalized
  #pod
  #pod This method returns true if the set of prereqs has been marked "finalized," and
  #pod cannot be altered.
  #pod
  #pod =cut
  
  sub is_finalized { $_[0]{finalized} }
  
  #pod =method finalize
  #pod
  #pod Calling C<finalize> on a Prereqs object will close it for further modification.
  #pod Attempting to make any changes that would actually alter the prereqs will
  #pod result in an exception being thrown.
  #pod
  #pod =cut
  
  sub finalize {
    my ($self) = @_;
  
    $self->{finalized} = 1;
  
    for my $phase (keys %{ $self->{prereqs} }) {
      $_->finalize for values %{ $self->{prereqs}{$phase} };
    }
  }
  
  #pod =method clone
  #pod
  #pod   my $cloned_prereqs = $prereqs->clone;
  #pod
  #pod This method returns a Prereqs object that is identical to the original object,
  #pod but can be altered without affecting the original object.  Finalization does
  #pod not survive cloning, meaning that you may clone a finalized set of prereqs and
  #pod then modify the clone.
  #pod
  #pod =cut
  
  sub clone {
    my ($self) = @_;
  
    my $clone = (ref $self)->new( $self->as_string_hash );
  }
  
  sub __uniq {
    my (%s, $u);
    grep { defined($_) ? !$s{$_}++ : !$u++ } @_;
  }
  
  1;
  
  # ABSTRACT: a set of distribution prerequisites by phase and type
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 DESCRIPTION
  
  A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
  distribution or one of its optional features.  Each set of prereqs is
  organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
  
  =head1 METHODS
  
  =head2 new
  
    my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
  
  This method returns a new set of Prereqs.  The input should look like the
  contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
  something more or less like this:
  
    my $prereq = CPAN::Meta::Prereqs->new({
      runtime => {
        requires => {
          'Some::Module' => '1.234',
          ...,
        },
        ...,
      },
      ...,
    });
  
  You can also construct an empty set of prereqs with:
  
    my $prereqs = CPAN::Meta::Prereqs->new;
  
  This empty set of prereqs is useful for accumulating new prereqs before finally
  dumping the whole set into a structure or string.
  
  =head2 requirements_for
  
    my $requirements = $prereqs->requirements_for( $phase, $type );
  
  This method returns a L<CPAN::Meta::Requirements> object for the given
  phase/type combination.  If no prerequisites are registered for that
  combination, a new CPAN::Meta::Requirements object will be returned, and it may
  be added to as needed.
  
  If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
  be raised.
  
  =head2 phases
  
    my @phases = $prereqs->phases;
  
  This method returns the list of all phases currently populated in the prereqs
  object, suitable for iterating.
  
  =head2 types_in
  
    my @runtime_types = $prereqs->types_in('runtime');
  
  This method returns the list of all types currently populated in the prereqs
  object for the provided phase, suitable for iterating.
  
  =head2 with_merged_prereqs
  
    my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
  
    my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
  
  This method returns a new CPAN::Meta::Prereqs objects in which all the
  other prerequisites given are merged into the current set.  This is primarily
  provided for combining a distribution's core prereqs with the prereqs of one of
  its optional features.
  
  The new prereqs object has no ties to the originals, and altering it further
  will not alter them.
  
  =head2 merged_requirements
  
      my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
      my $new_reqs = $prereqs->merged_requirements( \@phases );
      my $new_reqs = $prereqs->merged_requirements();
  
  This method joins together all requirements across a number of phases
  and types into a new L<CPAN::Meta::Requirements> object.  If arguments
  are omitted, it defaults to "runtime", "build" and "test" for phases
  and "requires" and "recommends" for types.
  
  =head2 as_string_hash
  
  This method returns a hashref containing structures suitable for dumping into a
  distmeta data structure.  It is made up of hashes and strings, only; there will
  be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
  
  =head2 is_finalized
  
  This method returns true if the set of prereqs has been marked "finalized," and
  cannot be altered.
  
  =head2 finalize
  
  Calling C<finalize> on a Prereqs object will close it for further modification.
  Attempting to make any changes that would actually alter the prereqs will
  result in an exception being thrown.
  
  =head2 clone
  
    my $cloned_prereqs = $prereqs->clone;
  
  This method returns a Prereqs object that is identical to the original object,
  but can be altered without affecting the original object.  Finalization does
  not survive cloning, meaning that you may clone a finalized set of prereqs and
  then modify the clone.
  
  =head1 BUGS
  
  Please report any bugs or feature using the CPAN Request Tracker.
  Bugs can be submitted through the web interface at
  L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
  
  When submitting a bug or request, please include a test-file or a patch to an
  existing test-file that illustrates the bug or desired feature.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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
  
  __END__
  
  
  # vim: ts=2 sts=2 sw=2 et :
CPAN_META_PREREQS

$fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS';
  use 5.006; # keep at v5.6 for CPAN.pm
  use strict;
  use warnings;
  package CPAN::Meta::Requirements;
  # ABSTRACT: a set of version requirements for a CPAN dist
  
  our $VERSION = '2.140';
  
  #pod =head1 SYNOPSIS
  #pod
  #pod   use CPAN::Meta::Requirements;
  #pod
  #pod   my $build_requires = CPAN::Meta::Requirements->new;
  #pod
  #pod   $build_requires->add_minimum('Library::Foo' => 1.208);
  #pod
  #pod   $build_requires->add_minimum('Library::Foo' => 2.602);
  #pod
  #pod   $build_requires->add_minimum('Module::Bar'  => 'v1.2.3');
  #pod
  #pod   $METAyml->{build_requires} = $build_requires->as_string_hash;
  #pod
  #pod =head1 DESCRIPTION
  #pod
  #pod A CPAN::Meta::Requirements object models a set of version constraints like
  #pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
  #pod and as defined by L<CPAN::Meta::Spec>;
  #pod It can be built up by adding more and more constraints, and it will reduce them
  #pod to the simplest representation.
  #pod
  #pod Logically impossible constraints will be identified immediately by thrown
  #pod exceptions.
  #pod
  #pod =cut
  
  use Carp ();
  
  # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
  # before 5.10, we fall back to the EUMM bundled compatibility version module if
  # that's the only thing available.  This shouldn't ever happen in a normal CPAN
  # install of CPAN::Meta::Requirements, as version.pm will be picked up from
  # prereqs and be available at runtime.
  
  BEGIN {
    eval "use version ()"; ## no critic
    if ( my $err = $@ ) {
      eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
    }
  }
  
  # Perl 5.10.0 didn't have "is_qv" in version.pm
  *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
  
  # construct once, reuse many times
  my $V0 = version->new(0);
  
  #pod =method new
  #pod
  #pod   my $req = CPAN::Meta::Requirements->new;
  #pod
  #pod This returns a new CPAN::Meta::Requirements object.  It takes an optional
  #pod hash reference argument.  Currently, only one key is supported:
  #pod
  #pod =for :list
  #pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
  #pod   a version object, this code reference will be called with the invalid
  #pod   version string as first argument, and the module name as second
  #pod   argument.  It must return a valid version object.
  #pod
  #pod All other keys are ignored.
  #pod
  #pod =cut
  
  my @valid_options = qw( bad_version_hook );
  
  sub new {
    my ($class, $options) = @_;
    $options ||= {};
    Carp::croak "Argument to $class\->new() must be a hash reference"
      unless ref $options eq 'HASH';
    my %self = map {; $_ => $options->{$_}} @valid_options;
  
    return bless \%self => $class;
  }
  
  # from version::vpp
  sub _find_magic_vstring {
    my $value = shift;
    my $tvalue = '';
    require B;
    my $sv = B::svref_2object(\$value);
    my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
    while ( $magic ) {
      if ( $magic->TYPE eq 'V' ) {
        $tvalue = $magic->PTR;
        $tvalue =~ s/^v?(.+)$/v$1/;
        last;
      }
      else {
        $magic = $magic->MOREMAGIC;
      }
    }
    return $tvalue;
  }
  
  # safe if given an unblessed reference
  sub _isa_version {
    UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
  }
  
  sub _version_object {
    my ($self, $module, $version) = @_;
  
    my ($vobj, $err);
  
    if (not defined $version or (!ref($version) && $version eq '0')) {
      return $V0;
    }
    elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
      $vobj = $version;
    }
    else {
      # hack around version::vpp not handling <3 character vstring literals
      if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
        my $magic = _find_magic_vstring( $version );
        $version = $magic if length $magic;
      }
      # pad to 3 characters if before 5.8.1 and appears to be a v-string
      if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
        $version .= "\0" x (3 - length($version));
      }
      eval {
        local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
        # avoid specific segfault on some older version.pm versions
        die "Invalid version: $version" if $version eq 'version';
        $vobj = version->new($version);
      };
      if ( my $err = $@ ) {
        my $hook = $self->{bad_version_hook};
        $vobj = eval { $hook->($version, $module) }
          if ref $hook eq 'CODE';
        unless (eval { $vobj->isa("version") }) {
          $err =~ s{ at .* line \d+.*$}{};
          die "Can't convert '$version': $err";
        }
      }
    }
  
    # ensure no leading '.'
    if ( $vobj =~ m{\A\.} ) {
      $vobj = version->new("0$vobj");
    }
  
    # ensure normal v-string form
    if ( _is_qv($vobj) ) {
      $vobj = version->new($vobj->normal);
    }
  
    return $vobj;
  }
  
  #pod =method add_minimum
  #pod
  #pod   $req->add_minimum( $module => $version );
  #pod
  #pod This adds a new minimum version requirement.  If the new requirement is
  #pod redundant to the existing specification, this has no effect.
  #pod
  #pod Minimum requirements are inclusive.  C<$version> is required, along with any
  #pod greater version number.
  #pod
  #pod This method returns the requirements object.
  #pod
  #pod =method add_maximum
  #pod
  #pod   $req->add_maximum( $module => $version );
  #pod
  #pod This adds a new maximum version requirement.  If the new requirement is
  #pod redundant to the existing specification, this has no effect.
  #pod
  #pod Maximum requirements are inclusive.  No version strictly greater than the given
  #pod version is allowed.
  #pod
  #pod This method returns the requirements object.
  #pod
  #pod =method add_exclusion
  #pod
  #pod   $req->add_exclusion( $module => $version );
  #pod
  #pod This adds a new excluded version.  For example, you might use these three
  #pod method calls:
  #pod
  #pod   $req->add_minimum( $module => '1.00' );
  #pod   $req->add_maximum( $module => '1.82' );
  #pod
  #pod   $req->add_exclusion( $module => '1.75' );
  #pod
  #pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
  #pod 1.75.
  #pod
  #pod This method returns the requirements object.
  #pod
  #pod =method exact_version
  #pod
  #pod   $req->exact_version( $module => $version );
  #pod
  #pod This sets the version required for the given module to I<exactly> the given
  #pod version.  No other version would be considered acceptable.
  #pod
  #pod This method returns the requirements object.
  #pod
  #pod =cut
  
  BEGIN {
    for my $type (qw(maximum exclusion exact_version)) {
      my $method = "with_$type";
      my $to_add = $type eq 'exact_version' ? $type : "add_$type";
  
      my $code = sub {
        my ($self, $name, $version) = @_;
  
        $version = $self->_version_object( $name, $version );
  
        $self->__modify_entry_for($name, $method, $version);
  
        return $self;
      };
  
      no strict 'refs';
      *$to_add = $code;
    }
  }
  
  # add_minimum is optimized compared to generated subs above because
  # it is called frequently and with "0" or equivalent input
  sub add_minimum {
    my ($self, $name, $version) = @_;
  
    # stringify $version so that version->new("0.00")->stringify ne "0"
    # which preserves the user's choice of "0.00" as the requirement
    if (not defined $version or "$version" eq '0') {
      return $self if $self->__entry_for($name);
      Carp::confess("can't add new requirements to finalized requirements")
        if $self->is_finalized;
  
      $self->{requirements}{ $name } =
        CPAN::Meta::Requirements::_Range::Range->with_minimum($V0, $name);
    }
    else {
      $version = $self->_version_object( $name, $version );
  
      $self->__modify_entry_for($name, 'with_minimum', $version);
    }
    return $self;
  }
  
  #pod =method add_requirements
  #pod
  #pod   $req->add_requirements( $another_req_object );
  #pod
  #pod This method adds all the requirements in the given CPAN::Meta::Requirements
  #pod object to the requirements object on which it was called.  If there are any
  #pod conflicts, an exception is thrown.
  #pod
  #pod This method returns the requirements object.
  #pod
  #pod =cut
  
  sub add_requirements {
    my ($self, $req) = @_;
  
    for my $module ($req->required_modules) {
      my $modifiers = $req->__entry_for($module)->as_modifiers;
      for my $modifier (@$modifiers) {
        my ($method, @args) = @$modifier;
        $self->$method($module => @args);
      };
    }
  
    return $self;
  }
  
  #pod =method accepts_module
  #pod
  #pod   my $bool = $req->accepts_module($module => $version);
  #pod
  #pod Given an module and version, this method returns true if the version
  #pod specification for the module accepts the provided version.  In other words,
  #pod given:
  #pod
  #pod   Module => '>= 1.00, < 2.00'
  #pod
  #pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
  #pod
  #pod For modules that do not appear in the requirements, this method will return
  #pod true.
  #pod
  #pod =cut
  
  sub accepts_module {
    my ($self, $module, $version) = @_;
  
    $version = $self->_version_object( $module, $version );
  
    return 1 unless my $range = $self->__entry_for($module);
    return $range->_accepts($version);
  }
  
  #pod =method clear_requirement
  #pod
  #pod   $req->clear_requirement( $module );
  #pod
  #pod This removes the requirement for a given module from the object.
  #pod
  #pod This method returns the requirements object.
  #pod
  #pod =cut
  
  sub clear_requirement {
    my ($self, $module) = @_;
  
    return $self unless $self->__entry_for($module);
  
    Carp::confess("can't clear requirements on finalized requirements")
      if $self->is_finalized;
  
    delete $self->{requirements}{ $module };
  
    return $self;
  }
  
  #pod =method requirements_for_module
  #pod
  #pod   $req->requirements_for_module( $module );
  #pod
  #pod This returns a string containing the version requirements for a given module in
  #pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
  #pod requirements. This should only be used for informational purposes such as error
  #pod messages and should not be interpreted or used for comparison (see
  #pod L</accepts_module> instead).
  #pod
  #pod =cut
  
  sub requirements_for_module {
    my ($self, $module) = @_;
    my $entry = $self->__entry_for($module);
    return unless $entry;
    return $entry->as_string;
  }
  
  #pod =method structured_requirements_for_module
  #pod
  #pod   $req->structured_requirements_for_module( $module );
  #pod
  #pod This returns a data structure containing the version requirements for a given
  #pod module or undef if the given module has no requirements.  This should
  #pod not be used for version checks (see L</accepts_module> instead).
  #pod
  #pod Added in version 2.134.
  #pod
  #pod =cut
  
  sub structured_requirements_for_module {
    my ($self, $module) = @_;
    my $entry = $self->__entry_for($module);
    return unless $entry;
    return $entry->as_struct;
  }
  
  #pod =method required_modules
  #pod
  #pod This method returns a list of all the modules for which requirements have been
  #pod specified.
  #pod
  #pod =cut
  
  sub required_modules { keys %{ $_[0]{requirements} } }
  
  #pod =method clone
  #pod
  #pod   $req->clone;
  #pod
  #pod This method returns a clone of the invocant.  The clone and the original object
  #pod can then be changed independent of one another.
  #pod
  #pod =cut
  
  sub clone {
    my ($self) = @_;
    my $new = (ref $self)->new;
  
    return $new->add_requirements($self);
  }
  
  sub __entry_for     { $_[0]{requirements}{ $_[1] } }
  
  sub __modify_entry_for {
    my ($self, $name, $method, $version) = @_;
  
    my $fin = $self->is_finalized;
    my $old = $self->__entry_for($name);
  
    Carp::confess("can't add new requirements to finalized requirements")
      if $fin and not $old;
  
    my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
            ->$method($version, $name);
  
    Carp::confess("can't modify finalized requirements")
      if $fin and $old->as_string ne $new->as_string;
  
    $self->{requirements}{ $name } = $new;
  }
  
  #pod =method is_simple
  #pod
  #pod This method returns true if and only if all requirements are inclusive minimums
  #pod -- that is, if their string expression is just the version number.
  #pod
  #pod =cut
  
  sub is_simple {
    my ($self) = @_;
    for my $module ($self->required_modules) {
      # XXX: This is a complete hack, but also entirely correct.
      return if $self->__entry_for($module)->as_string =~ /\s/;
    }
  
    return 1;
  }
  
  #pod =method is_finalized
  #pod
  #pod This method returns true if the requirements have been finalized by having the
  #pod C<finalize> method called on them.
  #pod
  #pod =cut
  
  sub is_finalized { $_[0]{finalized} }
  
  #pod =method finalize
  #pod
  #pod This method marks the requirements finalized.  Subsequent attempts to change
  #pod the requirements will be fatal, I<if> they would result in a change.  If they
  #pod would not alter the requirements, they have no effect.
  #pod
  #pod If a finalized set of requirements is cloned, the cloned requirements are not
  #pod also finalized.
  #pod
  #pod =cut
  
  sub finalize { $_[0]{finalized} = 1 }
  
  #pod =method as_string_hash
  #pod
  #pod This returns a reference to a hash describing the requirements using the
  #pod strings in the L<CPAN::Meta::Spec> specification.
  #pod
  #pod For example after the following program:
  #pod
  #pod   my $req = CPAN::Meta::Requirements->new;
  #pod
  #pod   $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
  #pod
  #pod   $req->add_minimum('Library::Foo' => 1.208);
  #pod
  #pod   $req->add_maximum('Library::Foo' => 2.602);
  #pod
  #pod   $req->add_minimum('Module::Bar'  => 'v1.2.3');
  #pod
  #pod   $req->add_exclusion('Module::Bar'  => 'v1.2.8');
  #pod
  #pod   $req->exact_version('Xyzzy'  => '6.01');
  #pod
  #pod   my $hashref = $req->as_string_hash;
  #pod
  #pod C<$hashref> would contain:
  #pod
  #pod   {
  #pod     'CPAN::Meta::Requirements' => '0.102',
  #pod     'Library::Foo' => '>= 1.208, <= 2.206',
  #pod     'Module::Bar'  => '>= v1.2.3, != v1.2.8',
  #pod     'Xyzzy'        => '== 6.01',
  #pod   }
  #pod
  #pod =cut
  
  sub as_string_hash {
    my ($self) = @_;
  
    my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
               $self->required_modules;
  
    return \%hash;
  }
  
  #pod =method add_string_requirement
  #pod
  #pod   $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
  #pod   $req->add_string_requirement('Library::Foo' => v1.208);
  #pod
  #pod This method parses the passed in string and adds the appropriate requirement
  #pod for the given module.  A version can be a Perl "v-string".  It understands
  #pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
  #pod example:
  #pod
  #pod =over 4
  #pod
  #pod =item 1.3
  #pod
  #pod =item >= 1.3
  #pod
  #pod =item <= 1.3
  #pod
  #pod =item == 1.3
  #pod
  #pod =item != 1.3
  #pod
  #pod =item > 1.3
  #pod
  #pod =item < 1.3
  #pod
  #pod =item >= 1.3, != 1.5, <= 2.0
  #pod
  #pod A version number without an operator is equivalent to specifying a minimum
  #pod (C<E<gt>=>).  Extra whitespace is allowed.
  #pod
  #pod =back
  #pod
  #pod =cut
  
  my %methods_for_op = (
    '==' => [ qw(exact_version) ],
    '!=' => [ qw(add_exclusion) ],
    '>=' => [ qw(add_minimum)   ],
    '<=' => [ qw(add_maximum)   ],
    '>'  => [ qw(add_minimum add_exclusion) ],
    '<'  => [ qw(add_maximum add_exclusion) ],
  );
  
  sub add_string_requirement {
    my ($self, $module, $req) = @_;
  
    unless ( defined $req && length $req ) {
      $req = 0;
      $self->_blank_carp($module);
    }
  
    my $magic = _find_magic_vstring( $req );
    if (length $magic) {
      $self->add_minimum($module => $magic);
      return;
    }
  
    my @parts = split qr{\s*,\s*}, $req;
  
    for my $part (@parts) {
      my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
  
      if (! defined $op) {
        $self->add_minimum($module => $part);
      } else {
        Carp::confess("illegal requirement string: $req")
          unless my $methods = $methods_for_op{ $op };
  
        $self->$_($module => $ver) for @$methods;
      }
    }
  }
  
  #pod =method from_string_hash
  #pod
  #pod   my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
  #pod   my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
  #pod
  #pod This is an alternate constructor for a CPAN::Meta::Requirements
  #pod object. It takes a hash of module names and version requirement
  #pod strings and returns a new CPAN::Meta::Requirements object. As with
  #pod add_string_requirement, a version can be a Perl "v-string". Optionally,
  #pod you can supply a hash-reference of options, exactly as with the L</new>
  #pod method.
  #pod
  #pod =cut
  
  sub _blank_carp {
    my ($self, $module) = @_;
    Carp::carp("Undefined requirement for $module treated as '0'");
  }
  
  sub from_string_hash {
    my ($class, $hash, $options) = @_;
  
    my $self = $class->new($options);
  
    for my $module (keys %$hash) {
      my $req = $hash->{$module};
      unless ( defined $req && length $req ) {
        $req = 0;
        $class->_blank_carp($module);
      }
      $self->add_string_requirement($module, $req);
    }
  
    return $self;
  }
  
  ##############################################################
  
  {
    package
      CPAN::Meta::Requirements::_Range::Exact;
    sub _new     { bless { version => $_[1] } => $_[0] }
  
    sub _accepts { return $_[0]{version} == $_[1] }
  
    sub as_string { return "== $_[0]{version}" }
  
    sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }
  
    sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
  
    sub _reject_requirements {
      my ($self, $module, $error) = @_;
      Carp::confess("illegal requirements for $module: $error")
    }
  
    sub _clone {
      (ref $_[0])->_new( version->new( $_[0]{version} ) )
    }
  
    sub with_exact_version {
      my ($self, $version, $module) = @_;
      $module = 'module' unless defined $module;
  
      return $self->_clone if $self->_accepts($version);
  
      $self->_reject_requirements(
        $module,
        "can't be exactly $version when exact requirement is already $self->{version}",
      );
    }
  
    sub with_minimum {
      my ($self, $minimum, $module) = @_;
      $module = 'module' unless defined $module;
  
      return $self->_clone if $self->{version} >= $minimum;
      $self->_reject_requirements(
        $module,
        "minimum $minimum exceeds exact specification $self->{version}",
      );
    }
  
    sub with_maximum {
      my ($self, $maximum, $module) = @_;
      $module = 'module' unless defined $module;
  
      return $self->_clone if $self->{version} <= $maximum;
      $self->_reject_requirements(
        $module,
        "maximum $maximum below exact specification $self->{version}",
      );
    }
  
    sub with_exclusion {
      my ($self, $exclusion, $module) = @_;
      $module = 'module' unless defined $module;
  
      return $self->_clone unless $exclusion == $self->{version};
      $self->_reject_requirements(
        $module,
        "tried to exclude $exclusion, which is already exactly specified",
      );
    }
  }
  
  ##############################################################
  
  {
    package
      CPAN::Meta::Requirements::_Range::Range;
  
    sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
  
    sub _clone {
      return (bless { } => $_[0]) unless ref $_[0];
  
      my ($s) = @_;
      my %guts = (
        (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
        (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
  
        (exists $s->{exclusions}
          ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
          : ()),
      );
  
      bless \%guts => ref($s);
    }
  
    sub as_modifiers {
      my ($self) = @_;
      my @mods;
      push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
      push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
      push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
      return \@mods;
    }
  
    sub as_struct {
      my ($self) = @_;
  
      return 0 if ! keys %$self;
  
      my @exclusions = @{ $self->{exclusions} || [] };
  
      my @parts;
  
      for my $tuple (
        [ qw( >= > minimum ) ],
        [ qw( <= < maximum ) ],
      ) {
        my ($op, $e_op, $k) = @$tuple;
        if (exists $self->{$k}) {
          my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
          if (@new_exclusions == @exclusions) {
            push @parts, [ $op, "$self->{ $k }" ];
          } else {
            push @parts, [ $e_op, "$self->{ $k }" ];
            @exclusions = @new_exclusions;
          }
        }
      }
  
      push @parts, map {; [ "!=", "$_" ] } @exclusions;
  
      return \@parts;
    }
  
    sub as_string {
      my ($self) = @_;
  
      my @parts = @{ $self->as_struct };
  
      return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';
  
      return join q{, }, map {; join q{ }, @$_ } @parts;
    }
  
    sub _reject_requirements {
      my ($self, $module, $error) = @_;
      Carp::confess("illegal requirements for $module: $error")
    }
  
    sub with_exact_version {
      my ($self, $version, $module) = @_;
      $module = 'module' unless defined $module;
      $self = $self->_clone;
  
      unless ($self->_accepts($version)) {
        $self->_reject_requirements(
          $module,
          "exact specification $version outside of range " . $self->as_string
        );
      }
  
      return CPAN::Meta::Requirements::_Range::Exact->_new($version);
    }
  
    sub _simplify {
      my ($self, $module) = @_;
  
      if (defined $self->{minimum} and defined $self->{maximum}) {
        if ($self->{minimum} == $self->{maximum}) {
          if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
            $self->_reject_requirements(
              $module,
              "minimum and maximum are both $self->{minimum}, which is excluded",
            );
          }
  
          return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
        }
  
        if ($self->{minimum} > $self->{maximum}) {
          $self->_reject_requirements(
            $module,
            "minimum $self->{minimum} exceeds maximum $self->{maximum}",
          );
        }
      }
  
      # eliminate irrelevant exclusions
      if ($self->{exclusions}) {
        my %seen;
        @{ $self->{exclusions} } = grep {
          (! defined $self->{minimum} or $_ >= $self->{minimum})
          and
          (! defined $self->{maximum} or $_ <= $self->{maximum})
          and
          ! $seen{$_}++
        } @{ $self->{exclusions} };
      }
  
      return $self;
    }
  
    sub with_minimum {
      my ($self, $minimum, $module) = @_;
      $module = 'module' unless defined $module;
      $self = $self->_clone;
  
      if (defined (my $old_min = $self->{minimum})) {
        $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
      } else {
        $self->{minimum} = $minimum;
      }
  
      return $self->_simplify($module);
    }
  
    sub with_maximum {
      my ($self, $maximum, $module) = @_;
      $module = 'module' unless defined $module;
      $self = $self->_clone;
  
      if (defined (my $old_max = $self->{maximum})) {
        $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
      } else {
        $self->{maximum} = $maximum;
      }
  
      return $self->_simplify($module);
    }
  
    sub with_exclusion {
      my ($self, $exclusion, $module) = @_;
      $module = 'module' unless defined $module;
      $self = $self->_clone;
  
      push @{ $self->{exclusions} ||= [] }, $exclusion;
  
      return $self->_simplify($module);
    }
  
    sub _accepts {
      my ($self, $version) = @_;
  
      return if defined $self->{minimum} and $version < $self->{minimum};
      return if defined $self->{maximum} and $version > $self->{maximum};
      return if defined $self->{exclusions}
            and grep { $version == $_ } @{ $self->{exclusions} };
  
      return 1;
    }
  }
  
  1;
  # vim: ts=2 sts=2 sw=2 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
  
  =head1 VERSION
  
  version 2.140
  
  =head1 SYNOPSIS
  
    use CPAN::Meta::Requirements;
  
    my $build_requires = CPAN::Meta::Requirements->new;
  
    $build_requires->add_minimum('Library::Foo' => 1.208);
  
    $build_requires->add_minimum('Library::Foo' => 2.602);
  
    $build_requires->add_minimum('Module::Bar'  => 'v1.2.3');
  
    $METAyml->{build_requires} = $build_requires->as_string_hash;
  
  =head1 DESCRIPTION
  
  A CPAN::Meta::Requirements object models a set of version constraints like
  those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
  and as defined by L<CPAN::Meta::Spec>;
  It can be built up by adding more and more constraints, and it will reduce them
  to the simplest representation.
  
  Logically impossible constraints will be identified immediately by thrown
  exceptions.
  
  =head1 METHODS
  
  =head2 new
  
    my $req = CPAN::Meta::Requirements->new;
  
  This returns a new CPAN::Meta::Requirements object.  It takes an optional
  hash reference argument.  Currently, only one key is supported:
  
  =over 4
  
  =item *
  
  C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument.  It must return a valid version object.
  
  =back
  
  All other keys are ignored.
  
  =head2 add_minimum
  
    $req->add_minimum( $module => $version );
  
  This adds a new minimum version requirement.  If the new requirement is
  redundant to the existing specification, this has no effect.
  
  Minimum requirements are inclusive.  C<$version> is required, along with any
  greater version number.
  
  This method returns the requirements object.
  
  =head2 add_maximum
  
    $req->add_maximum( $module => $version );
  
  This adds a new maximum version requirement.  If the new requirement is
  redundant to the existing specification, this has no effect.
  
  Maximum requirements are inclusive.  No version strictly greater than the given
  version is allowed.
  
  This method returns the requirements object.
  
  =head2 add_exclusion
  
    $req->add_exclusion( $module => $version );
  
  This adds a new excluded version.  For example, you might use these three
  method calls:
  
    $req->add_minimum( $module => '1.00' );
    $req->add_maximum( $module => '1.82' );
  
    $req->add_exclusion( $module => '1.75' );
  
  Any version between 1.00 and 1.82 inclusive would be acceptable, except for
  1.75.
  
  This method returns the requirements object.
  
  =head2 exact_version
  
    $req->exact_version( $module => $version );
  
  This sets the version required for the given module to I<exactly> the given
  version.  No other version would be considered acceptable.
  
  This method returns the requirements object.
  
  =head2 add_requirements
  
    $req->add_requirements( $another_req_object );
  
  This method adds all the requirements in the given CPAN::Meta::Requirements
  object to the requirements object on which it was called.  If there are any
  conflicts, an exception is thrown.
  
  This method returns the requirements object.
  
  =head2 accepts_module
  
    my $bool = $req->accepts_module($module => $version);
  
  Given an module and version, this method returns true if the version
  specification for the module accepts the provided version.  In other words,
  given:
  
    Module => '>= 1.00, < 2.00'
  
  We will accept 1.00 and 1.75 but not 0.50 or 2.00.
  
  For modules that do not appear in the requirements, this method will return
  true.
  
  =head2 clear_requirement
  
    $req->clear_requirement( $module );
  
  This removes the requirement for a given module from the object.
  
  This method returns the requirements object.
  
  =head2 requirements_for_module
  
    $req->requirements_for_module( $module );
  
  This returns a string containing the version requirements for a given module in
  the format described in L<CPAN::Meta::Spec> or undef if the given module has no
  requirements. This should only be used for informational purposes such as error
  messages and should not be interpreted or used for comparison (see
  L</accepts_module> instead).
  
  =head2 structured_requirements_for_module
  
    $req->structured_requirements_for_module( $module );
  
  This returns a data structure containing the version requirements for a given
  module or undef if the given module has no requirements.  This should
  not be used for version checks (see L</accepts_module> instead).
  
  Added in version 2.134.
  
  =head2 required_modules
  
  This method returns a list of all the modules for which requirements have been
  specified.
  
  =head2 clone
  
    $req->clone;
  
  This method returns a clone of the invocant.  The clone and the original object
  can then be changed independent of one another.
  
  =head2 is_simple
  
  This method returns true if and only if all requirements are inclusive minimums
  -- that is, if their string expression is just the version number.
  
  =head2 is_finalized
  
  This method returns true if the requirements have been finalized by having the
  C<finalize> method called on them.
  
  =head2 finalize
  
  This method marks the requirements finalized.  Subsequent attempts to change
  the requirements will be fatal, I<if> they would result in a change.  If they
  would not alter the requirements, they have no effect.
  
  If a finalized set of requirements is cloned, the cloned requirements are not
  also finalized.
  
  =head2 as_string_hash
  
  This returns a reference to a hash describing the requirements using the
  strings in the L<CPAN::Meta::Spec> specification.
  
  For example after the following program:
  
    my $req = CPAN::Meta::Requirements->new;
  
    $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
  
    $req->add_minimum('Library::Foo' => 1.208);
  
    $req->add_maximum('Library::Foo' => 2.602);
  
    $req->add_minimum('Module::Bar'  => 'v1.2.3');
  
    $req->add_exclusion('Module::Bar'  => 'v1.2.8');
  
    $req->exact_version('Xyzzy'  => '6.01');
  
    my $hashref = $req->as_string_hash;
  
  C<$hashref> would contain:
  
    {
      'CPAN::Meta::Requirements' => '0.102',
      'Library::Foo' => '>= 1.208, <= 2.206',
      'Module::Bar'  => '>= v1.2.3, != v1.2.8',
      'Xyzzy'        => '== 6.01',
    }
  
  =head2 add_string_requirement
  
    $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
    $req->add_string_requirement('Library::Foo' => v1.208);
  
  This method parses the passed in string and adds the appropriate requirement
  for the given module.  A version can be a Perl "v-string".  It understands
  version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
  example:
  
  =over 4
  
  =item 1.3
  
  =item >= 1.3
  
  =item <= 1.3
  
  =item == 1.3
  
  =item != 1.3
  
  =item > 1.3
  
  =item < 1.3
  
  =item >= 1.3, != 1.5, <= 2.0
  
  A version number without an operator is equivalent to specifying a minimum
  (C<E<gt>=>).  Extra whitespace is allowed.
  
  =back
  
  =head2 from_string_hash
  
    my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
    my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
  
  This is an alternate constructor for a CPAN::Meta::Requirements
  object. It takes a hash of module names and version requirement
  strings and returns a new CPAN::Meta::Requirements object. As with
  add_string_requirement, a version can be a Perl "v-string". Optionally,
  you can supply a hash-reference of options, exactly as with the L</new>
  method.
  
  =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/Perl-Toolchain-Gang/CPAN-Meta-Requirements/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/Perl-Toolchain-Gang/CPAN-Meta-Requirements>
  
    git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =for stopwords Ed J Karen Etheridge Leon Timmermans robario
  
  =over 4
  
  =item *
  
  Ed J <mohawk2@users.noreply.github.com>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Leon Timmermans <fawaka@gmail.com>
  
  =item *
  
  robario <webmaster@robario.com>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden and Ricardo Signes.
  
  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_META_REQUIREMENTS

$fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC';
  # XXX RULES FOR PATCHING THIS FILE XXX
  # Patches that fix typos or formatting are acceptable.  Patches
  # that change semantics are not acceptable without prior approval
  # by David Golden or Ricardo Signes.
  
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta::Spec;
  
  our $VERSION = '2.150010';
  
  1;
  
  # ABSTRACT: specification for CPAN distribution metadata
  
  
  # vi:tw=72
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Spec - specification for CPAN distribution metadata
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 SYNOPSIS
  
    my $distmeta = {
      name => 'Module-Build',
      abstract => 'Build and install Perl modules',
      description =>  "Module::Build is a system for "
        . "building, testing, and installing Perl modules. "
        . "It is meant to ... blah blah blah ...",
      version  => '0.36',
      release_status => 'stable',
      author   => [
        'Ken Williams <kwilliams@cpan.org>',
        'Module-Build List <module-build@perl.org>', # additional contact
      ],
      license  => [ 'perl_5' ],
      prereqs => {
        runtime => {
          requires => {
            'perl'   => '5.006',
            'ExtUtils::Install' => '0',
            'File::Basename' => '0',
            'File::Compare'  => '0',
            'IO::File'   => '0',
          },
          recommends => {
            'Archive::Tar' => '1.00',
            'ExtUtils::Install' => '0.3',
            'ExtUtils::ParseXS' => '2.02',
          },
        },
        build => {
          requires => {
            'Test::More' => '0',
          },
        }
      },
      resources => {
        license => ['http://dev.perl.org/licenses/'],
      },
      optional_features => {
        domination => {
          description => 'Take over the world',
          prereqs     => {
            develop => { requires => { 'Genius::Evil'     => '1.234' } },
            runtime => { requires => { 'Machine::Weather' => '2.0'   } },
          },
        },
      },
      dynamic_config => 1,
      keywords => [ qw/ toolchain cpan dual-life / ],
      'meta-spec' => {
        version => '2',
        url     => 'https://metacpan.org/pod/CPAN::Meta::Spec',
      },
      generated_by => 'Module::Build version 0.36',
    };
  
  =head1 DESCRIPTION
  
  This document describes version 2 of the CPAN distribution metadata
  specification, also known as the "CPAN Meta Spec".
  
  Revisions of this specification for typo corrections and prose
  clarifications may be issued as CPAN::Meta::Spec 2.I<x>.  These
  revisions will never change semantics or add or remove specified
  behavior.
  
  Distribution metadata describe important properties of Perl
  distributions. Distribution building tools like Module::Build,
  Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
  metadata file in accordance with this specification and include it with
  the distribution for use by automated tools that index, examine, package
  or install Perl distributions.
  
  =head1 TERMINOLOGY
  
  =over 4
  
  =item distribution
  
  This is the primary object described by the metadata. In the context of
  this document it usually refers to a collection of modules, scripts,
  and/or documents that are distributed together for other developers to
  use.  Examples of distributions are C<Class-Container>, C<libwww-perl>,
  or C<DBI>.
  
  =item module
  
  This refers to a reusable library of code contained in a single file.
  Modules usually contain one or more packages and are often referred
  to by the name of a primary package that can be mapped to the file
  name. For example, one might refer to C<File::Spec> instead of
  F<File/Spec.pm>
  
  =item package
  
  This refers to a namespace declared with the Perl C<package> statement.
  In Perl, packages often have a version number property given by the
  C<$VERSION> variable in the namespace.
  
  =item consumer
  
  This refers to code that reads a metadata file, deserializes it into a
  data structure in memory, or interprets a data structure of metadata
  elements.
  
  =item producer
  
  This refers to code that constructs a metadata data structure,
  serializes into a bytestream and/or writes it to disk.
  
  =item must, should, may, etc.
  
  These terms are interpreted as described in IETF RFC 2119.
  
  =back
  
  =head1 DATA TYPES
  
  Fields in the L</STRUCTURE> section describe data elements, each of
  which has an associated data type as described herein.  There are four
  primitive types: Boolean, String, List and Map.  Other types are
  subtypes of primitives and define compound data structures or define
  constraints on the values of a data element.
  
  =head2 Boolean
  
  A I<Boolean> is used to provide a true or false value.  It B<must> be
  represented as a defined value that is either "1" or "0" or stringifies
  to those values.
  
  =head2 String
  
  A I<String> is data element containing a non-zero length sequence of
  Unicode characters, such as an ordinary Perl scalar that is not a
  reference.
  
  =head2 List
  
  A I<List> is an ordered collection of zero or more data elements.
  Elements of a List may be of mixed types.
  
  Producers B<must> represent List elements using a data structure which
  unambiguously indicates that multiple values are possible, such as a
  reference to a Perl array (an "arrayref").
  
  Consumers expecting a List B<must> consider a String as equivalent to a
  List of length 1.
  
  =head2 Map
  
  A I<Map> is an unordered collection of zero or more data elements
  ("values"), indexed by associated String elements ("keys").  The Map's
  value elements may be of mixed types.
  
  =head2 License String
  
  A I<License String> is a subtype of String with a restricted set of
  values.  Valid values are described in detail in the description of
  the L</license> field.
  
  =head2 URL
  
  I<URL> is a subtype of String containing a Uniform Resource Locator or
  Identifier.  [ This type is called URL and not URI for historical reasons. ]
  
  =head2 Version
  
  A I<Version> is a subtype of String containing a value that describes
  the version number of packages or distributions.  Restrictions on format
  are described in detail in the L</Version Formats> section.
  
  =head2 Version Range
  
  The I<Version Range> type is a subtype of String.  It describes a range
  of Versions that may be present or installed to fulfill prerequisites.
  It is specified in detail in the L</Version Ranges> section.
  
  =head1 STRUCTURE
  
  The metadata structure is a data element of type Map.  This section
  describes valid keys within the Map.
  
  Any keys not described in this specification document (whether top-level
  or within compound data structures described herein) are considered
  I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
  underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>.  If a
  custom key refers to a compound data structure, subkeys within it do not
  need an "x_" or "X_" prefix.
  
  Consumers of metadata may ignore any or all custom keys.  All other keys
  not described herein are invalid and should be ignored by consumers.
  Producers must not generate or output invalid keys.
  
  For each key, an example is provided followed by a description.  The
  description begins with the version of spec in which the key was added
  or in which the definition was modified, whether the key is I<required>
  or I<optional> and the data type of the corresponding data element.
  These items are in parentheses, brackets and braces, respectively.
  
  If a data type is a Map or Map subtype, valid subkeys will be described
  as well.
  
  Some fields are marked I<Deprecated>.  These are shown for historical
  context and must not be produced in or consumed from any metadata structure
  of version 2 or higher.
  
  =head2 REQUIRED FIELDS
  
  =head3 abstract
  
  Example:
  
    abstract => 'Build and install Perl modules'
  
  (Spec 1.2) [required] {String}
  
  This is a short description of the purpose of the distribution.
  
  =head3 author
  
  Example:
  
    author => [ 'Ken Williams <kwilliams@cpan.org>' ]
  
  (Spec 1.2) [required] {List of one or more Strings}
  
  This List indicates the person(s) to contact concerning the
  distribution. The preferred form of the contact string is:
  
    contact-name <email-address>
  
  This field provides a general contact list independent of other
  structured fields provided within the L</resources> field, such as
  C<bugtracker>.  The addressee(s) can be contacted for any purpose
  including but not limited to (security) problems with the distribution,
  questions about the distribution or bugs in the distribution.
  
  A distribution's original author is usually the contact listed within
  this field.  Co-maintainers, successor maintainers or mailing lists
  devoted to the distribution may also be listed in addition to or instead
  of the original author.
  
  =head3 dynamic_config
  
  Example:
  
    dynamic_config => 1
  
  (Spec 2) [required] {Boolean}
  
  A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
  similar) must be executed to determine prerequisites.
  
  This field should be set to a true value if the distribution performs
  some dynamic configuration (asking questions, sensing the environment,
  etc.) as part of its configuration.  This field should be set to a false
  value to indicate that prerequisites included in metadata may be
  considered final and valid for static analysis.
  
  Note: when this field is true, post-configuration prerequisites are not
  guaranteed to bear any relation whatsoever to those stated in the metadata,
  and relying on them doing so is an error. See also
  L</Prerequisites for dynamically configured distributions> in the implementors'
  notes.
  
  This field explicitly B<does not> indicate whether installation may be
  safely performed without using a Makefile or Build file, as there may be
  special files to install or custom installation targets (e.g. for
  dual-life modules that exist on CPAN as well as in the Perl core).  This
  field only defines whether or not prerequisites are exactly as given in the
  metadata.
  
  =head3 generated_by
  
  Example:
  
    generated_by => 'Module::Build version 0.36'
  
  (Spec 1.0) [required] {String}
  
  This field indicates the tool that was used to create this metadata.
  There are no defined semantics for this field, but it is traditional to
  use a string in the form "Generating::Package version 1.23" or the
  author's name, if the file was generated by hand.
  
  =head3 license
  
  Example:
  
    license => [ 'perl_5' ]
  
    license => [ 'apache_2_0', 'mozilla_1_0' ]
  
  (Spec 2) [required] {List of one or more License Strings}
  
  One or more licenses that apply to some or all of the files in the
  distribution.  If multiple licenses are listed, the distribution
  documentation should be consulted to clarify the interpretation of
  multiple licenses.
  
  The following list of license strings are valid:
  
   string          description
   -------------   -----------------------------------------------
   agpl_3          GNU Affero General Public License, Version 3
   apache_1_1      Apache Software License, Version 1.1
   apache_2_0      Apache License, Version 2.0
   artistic_1      Artistic License, (Version 1)
   artistic_2      Artistic License, Version 2.0
   bsd             BSD License (three-clause)
   freebsd         FreeBSD License (two-clause)
   gfdl_1_2        GNU Free Documentation License, Version 1.2
   gfdl_1_3        GNU Free Documentation License, Version 1.3
   gpl_1           GNU General Public License, Version 1
   gpl_2           GNU General Public License, Version 2
   gpl_3           GNU General Public License, Version 3
   lgpl_2_1        GNU Lesser General Public License, Version 2.1
   lgpl_3_0        GNU Lesser General Public License, Version 3.0
   mit             MIT (aka X11) License
   mozilla_1_0     Mozilla Public License, Version 1.0
   mozilla_1_1     Mozilla Public License, Version 1.1
   openssl         OpenSSL License
   perl_5          The Perl 5 License (Artistic 1 & GPL 1 or later)
   qpl_1_0         Q Public License, Version 1.0
   ssleay          Original SSLeay License
   sun             Sun Internet Standards Source License (SISSL)
   zlib            zlib License
  
  The following license strings are also valid and indicate other
  licensing not described above:
  
   string          description
   -------------   -----------------------------------------------
   open_source     Other Open Source Initiative (OSI) approved license
   restricted      Requires special permission from copyright holder
   unrestricted    Not an OSI approved license, but not restricted
   unknown         License not provided in metadata
  
  All other strings are invalid in the license field.
  
  =head3 meta-spec
  
  Example:
  
    'meta-spec' => {
      version => '2',
      url     => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
    }
  
  (Spec 1.2) [required] {Map}
  
  This field indicates the version of the CPAN Meta Spec that should be
  used to interpret the metadata.  Consumers must check this key as soon
  as possible and abort further metadata processing if the meta-spec
  version is not supported by the consumer.
  
  The following keys are valid, but only C<version> is required.
  
  =over
  
  =item version
  
  This subkey gives the integer I<Version> of the CPAN Meta Spec against
  which the document was generated.
  
  =item url
  
  This is a I<URL> of the metadata specification document corresponding to
  the given version.  This is strictly for human-consumption and should
  not impact the interpretation of the document.
  
  For the version 2 spec, either of these are recommended:
  
  =over 4
  
  =item *
  
  C<https://metacpan.org/pod/CPAN::Meta::Spec>
  
  =item *
  
  C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>
  
  =back
  
  =back
  
  =head3 name
  
  Example:
  
    name => 'Module-Build'
  
  (Spec 1.0) [required] {String}
  
  This field is the name of the distribution.  This is often created by
  taking the "main package" in the distribution and changing C<::> to
  C<->, but the name may be completely unrelated to the packages within
  the distribution.  For example, L<LWP::UserAgent> is distributed as part
  of the distribution name "libwww-perl".
  
  =head3 release_status
  
  Example:
  
    release_status => 'stable'
  
  (Spec 2) [required] {String}
  
  This field provides the  release status of this distribution.  If the
  C<version> field contains an underscore character, then
  C<release_status> B<must not> be "stable."
  
  The C<release_status> field B<must> have one of the following values:
  
  =over
  
  =item stable
  
  This indicates an ordinary, "final" release that should be indexed by PAUSE
  or other indexers.
  
  =item testing
  
  This indicates a "beta" release that is substantially complete, but has an
  elevated risk of bugs and requires additional testing.  The distribution
  should not be installed over a stable release without an explicit request
  or other confirmation from a user.  This release status may also be used
  for "release candidate" versions of a distribution.
  
  =item unstable
  
  This indicates an "alpha" release that is under active development, but has
  been released for early feedback or testing and may be missing features or
  may have serious bugs.  The distribution should not be installed over a
  stable release without an explicit request or other confirmation from a
  user.
  
  =back
  
  Consumers B<may> use this field to determine how to index the
  distribution for CPAN or other repositories in addition to or in
  replacement of heuristics based on version number or file name.
  
  =head3 version
  
  Example:
  
    version => '0.36'
  
  (Spec 1.0) [required] {Version}
  
  This field gives the version of the distribution to which the metadata
  structure refers.
  
  =head2 OPTIONAL FIELDS
  
  =head3 description
  
  Example:
  
      description =>  "Module::Build is a system for "
        . "building, testing, and installing Perl modules. "
        . "It is meant to ... blah blah blah ...",
  
  (Spec 2) [optional] {String}
  
  A longer, more complete description of the purpose or intended use of
  the distribution than the one provided by the C<abstract> key.
  
  =head3 keywords
  
  Example:
  
    keywords => [ qw/ toolchain cpan dual-life / ]
  
  (Spec 1.1) [optional] {List of zero or more Strings}
  
  A List of keywords that describe this distribution.  Keywords
  B<must not> include whitespace.
  
  =head3 no_index
  
  Example:
  
    no_index => {
      file      => [ 'My/Module.pm' ],
      directory => [ 'My/Private' ],
      package   => [ 'My::Module::Secret' ],
      namespace => [ 'My::Module::Sample' ],
    }
  
  (Spec 1.2) [optional] {Map}
  
  This Map describes any files, directories, packages, and namespaces that
  are private to the packaging or implementation of the distribution and
  should be ignored by indexing or search tools. Note that this is a list of
  exclusions, and the spec does not define what to I<include> - see
  L</Indexing distributions a la PAUSE> in the implementors notes for more
  information.
  
  Valid subkeys are as follows:
  
  =over
  
  =item file
  
  A I<List> of relative paths to files.  Paths B<must be> specified with
  unix conventions.
  
  =item directory
  
  A I<List> of relative paths to directories.  Paths B<must be> specified
  with unix conventions.
  
  [ Note: previous editions of the spec had C<dir> instead of C<directory> ]
  
  =item package
  
  A I<List> of package names.
  
  =item namespace
  
  A I<List> of package namespaces, where anything below the namespace
  must be ignored, but I<not> the namespace itself.
  
  In the example above for C<no_index>, C<My::Module::Sample::Foo> would
  be ignored, but C<My::Module::Sample> would not.
  
  =back
  
  =head3 optional_features
  
  Example:
  
    optional_features => {
      sqlite => {
        description => 'Provides SQLite support',
        prereqs => {
          runtime => {
            requires => {
              'DBD::SQLite' => '1.25'
            }
          }
        }
      }
    }
  
  (Spec 2) [optional] {Map}
  
  This Map describes optional features with incremental prerequisites.
  Each key of the C<optional_features> Map is a String used to identify
  the feature and each value is a Map with additional information about
  the feature.  Valid subkeys include:
  
  =over
  
  =item description
  
  This is a String describing the feature.  Every optional feature
  should provide a description
  
  =item prereqs
  
  This entry is required and has the same structure as that of the
  C<L</prereqs>> key.  It provides a list of package requirements
  that must be satisfied for the feature to be supported or enabled.
  
  There is one crucial restriction:  the prereqs of an optional feature
  B<must not> include C<configure> phase prereqs.
  
  =back
  
  Consumers B<must not> include optional features as prerequisites without
  explicit instruction from users (whether via interactive prompting,
  a function parameter or a configuration value, etc. ).
  
  If an optional feature is used by a consumer to add additional
  prerequisites, the consumer should merge the optional feature
  prerequisites into those given by the C<prereqs> key using the same
  semantics.  See L</Merging and Resolving Prerequisites> for details on
  merging prerequisites.
  
  I<Suggestion for disuse:> Because there is currently no way for a
  distribution to specify a dependency on an optional feature of another
  dependency, the use of C<optional_feature> is discouraged.  Instead,
  create a separate, installable distribution that ensures the desired
  feature is available.  For example, if C<Foo::Bar> has a C<Baz> feature,
  release a separate C<Foo-Bar-Baz> distribution that satisfies
  requirements for the feature.
  
  =head3 prereqs
  
  Example:
  
    prereqs => {
      runtime => {
        requires => {
          'perl'          => '5.006',
          'File::Spec'    => '0.86',
          'JSON'          => '2.16',
        },
        recommends => {
          'JSON::XS'      => '2.26',
        },
        suggests => {
          'Archive::Tar'  => '0',
        },
      },
      build => {
        requires => {
          'Alien::SDL'    => '1.00',
        },
      },
      test => {
        recommends => {
          'Test::Deep'    => '0.10',
        },
      }
    }
  
  (Spec 2) [optional] {Map}
  
  This is a Map that describes all the prerequisites of the distribution.
  The keys are phases of activity, such as C<configure>, C<build>, C<test>
  or C<runtime>.  Values are Maps in which the keys name the type of
  prerequisite relationship such as C<requires>, C<recommends>, or
  C<suggests> and the value provides a set of prerequisite relations.  The
  set of relations B<must> be specified as a Map of package names to
  version ranges.
  
  The full definition for this field is given in the L</Prereq Spec>
  section.
  
  =head3 provides
  
  Example:
  
    provides => {
      'Foo::Bar' => {
        file    => 'lib/Foo/Bar.pm',
        version => '0.27_02',
      },
      'Foo::Bar::Blah' => {
        file    => 'lib/Foo/Bar/Blah.pm',
      },
      'Foo::Bar::Baz' => {
        file    => 'lib/Foo/Bar/Baz.pm',
        version => '0.3',
      },
    }
  
  (Spec 1.2) [optional] {Map}
  
  This describes all packages provided by this distribution.  This
  information is used by distribution and automation mechanisms like
  PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
  which distribution various packages can be found.
  
  The keys of C<provides> are package names that can be found within
  the distribution.  If a package name key is provided, it must
  have a Map with the following valid subkeys:
  
  =over
  
  =item file
  
  This field is required.  It must contain a Unix-style relative file path
  from the root of the distribution directory to a file that contains or
  generates the package.  It may be given as C<META.yml> or C<META.json>
  to claim a package for indexing without needing a C<*.pm>.
  
  =item version
  
  If it exists, this field must contains a I<Version> String for the
  package.  If the package does not have a C<$VERSION>, this field must
  be omitted.
  
  =back
  
  =head3 resources
  
  Example:
  
    resources => {
      license     => [ 'http://dev.perl.org/licenses/' ],
      homepage    => 'http://sourceforge.net/projects/module-build',
      bugtracker  => {
        web    => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
        mailto => 'meta-bugs@example.com',
      },
      repository  => {
        url  => 'git://github.com/dagolden/cpan-meta.git',
        web  => 'http://github.com/dagolden/cpan-meta',
        type => 'git',
      },
      x_twitter   => 'http://twitter.com/cpan_linked/',
    }
  
  (Spec 2) [optional] {Map}
  
  This field describes resources related to this distribution.
  
  Valid subkeys include:
  
  =over
  
  =item homepage
  
  The official home of this project on the web.
  
  =item license
  
  A List of I<URL>'s that relate to this distribution's license.  As with the
  top-level C<license> field, distribution documentation should be consulted
  to clarify the interpretation of multiple licenses provided here.
  
  =item bugtracker
  
  This entry describes the bug tracking system for this distribution.  It
  is a Map with the following valid keys:
  
    web    - a URL pointing to a web front-end for the bug tracker
    mailto - an email address to which bugs can be sent
  
  =item repository
  
  This entry describes the source control repository for this distribution.  It
  is a Map with the following valid keys:
  
    url  - a URL pointing to the repository itself
    web  - a URL pointing to a web front-end for the repository
    type - a lowercase string indicating the VCS used
  
  Because a url like C<http://myrepo.example.com/> is ambiguous as to
  type, producers should provide a C<type> whenever a C<url> key is given.
  The C<type> field should be the name of the most common program used
  to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
  C<bzr> or C<hg>.
  
  =back
  
  =head2 DEPRECATED FIELDS
  
  =head3 build_requires
  
  I<(Deprecated in Spec 2)> [optional] {String}
  
  Replaced by C<prereqs>
  
  =head3 configure_requires
  
  I<(Deprecated in Spec 2)> [optional] {String}
  
  Replaced by C<prereqs>
  
  =head3 conflicts
  
  I<(Deprecated in Spec 2)> [optional] {String}
  
  Replaced by C<prereqs>
  
  =head3 distribution_type
  
  I<(Deprecated in Spec 2)> [optional] {String}
  
  This field indicated 'module' or 'script' but was considered
  meaningless, since many distributions are hybrids of several kinds of
  things.
  
  =head3 license_uri
  
  I<(Deprecated in Spec 1.2)> [optional] {URL}
  
  Replaced by C<license> in C<resources>
  
  =head3 private
  
  I<(Deprecated in Spec 1.2)> [optional] {Map}
  
  This field has been renamed to L</"no_index">.
  
  =head3 recommends
  
  I<(Deprecated in Spec 2)> [optional] {String}
  
  Replaced by C<prereqs>
  
  =head3 requires
  
  I<(Deprecated in Spec 2)> [optional] {String}
  
  Replaced by C<prereqs>
  
  =head1 VERSION NUMBERS
  
  =head2 Version Formats
  
  This section defines the Version type, used by several fields in the
  CPAN Meta Spec.
  
  Version numbers must be treated as strings, not numbers.  For
  example, C<1.200> B<must not> be serialized as C<1.2>.  Version
  comparison should be delegated to the Perl L<version> module, version
  0.80 or newer.
  
  Unless otherwise specified, version numbers B<must> appear in one of two
  formats:
  
  =over
  
  =item Decimal versions
  
  Decimal versions are regular "decimal numbers", with some limitations.
  They B<must> be non-negative and B<must> begin and end with a digit.  A
  single underscore B<may> be included, but B<must> be between two digits.
  They B<must not> use exponential notation ("1.23e-2").
  
     version => '1.234'       # OK
     version => '1.23_04'     # OK
  
     version => '1.23_04_05'  # Illegal
     version => '1.'          # Illegal
     version => '.1'          # Illegal
  
  =item Dotted-integer versions
  
  Dotted-integer (also known as dotted-decimal) versions consist of
  positive integers separated by full stop characters (i.e. "dots",
  "periods" or "decimal points").  This are equivalent in format to Perl
  "v-strings", with some additional restrictions on form.  They must be
  given in "normal" form, which has a leading "v" character and at least
  three integer components.  To retain a one-to-one mapping with decimal
  versions, all components after the first B<should> be restricted to the
  range 0 to 999.  The final component B<may> be separated by an
  underscore character instead of a period.
  
     version => 'v1.2.3'      # OK
     version => 'v1.2_3'      # OK
     version => 'v1.2.3.4'    # OK
     version => 'v1.2.3_4'    # OK
     version => 'v2009.10.31' # OK
  
     version => 'v1.2'          # Illegal
     version => '1.2.3'         # Illegal
     version => 'v1.2_3_4'      # Illegal
     version => 'v1.2009.10.31' # Not recommended
  
  =back
  
  =head2 Version Ranges
  
  Some fields (prereq, optional_features) indicate the particular
  version(s) of some other module that may be required as a prerequisite.
  This section details the Version Range type used to provide this
  information.
  
  The simplest format for a Version Range is just the version
  number itself, e.g. C<2.4>.  This means that B<at least> version 2.4
  must be present.  To indicate that B<any> version of a prerequisite is
  okay, even if the prerequisite doesn't define a version at all, use
  the version C<0>.
  
  Alternatively, a version range B<may> use the operators E<lt> (less than),
  E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
  or equal), == (equal), and != (not equal).  For example, the
  specification C<E<lt> 2.0> means that any version of the prerequisite
  less than 2.0 is suitable.
  
  For more complicated situations, version specifications B<may> be AND-ed
  together using commas.  The specification C<E<gt>= 1.2, != 1.5, E<lt>
  2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
  and B<not equal to> 1.5.
  
  =head1 PREREQUISITES
  
  =head2 Prereq Spec
  
  The C<prereqs> key in the top-level metadata and within
  C<optional_features> define the relationship between a distribution and
  other packages.  The prereq spec structure is a hierarchical data
  structure which divides prerequisites into I<Phases> of activity in the
  installation process and I<Relationships> that indicate how
  prerequisites should be resolved.
  
  For example, to specify that C<Data::Dumper> is C<required> during the
  C<test> phase, this entry would appear in the distribution metadata:
  
    prereqs => {
      test => {
        requires => {
          'Data::Dumper' => '2.00'
        }
      }
    }
  
  =head3 Phases
  
  Requirements for regular use must be listed in the C<runtime> phase.
  Other requirements should be listed in the earliest stage in which they
  are required and consumers must accumulate and satisfy requirements
  across phases before executing the activity. For example, C<build>
  requirements must also be available during the C<test> phase.
  
    before action       requirements that must be met
    ----------------    --------------------------------
    perl Build.PL       configure
    perl Makefile.PL
  
    make                configure, runtime, build
    Build
  
    make test           configure, runtime, build, test
    Build test
  
  Consumers that install the distribution must ensure that
  I<runtime> requirements are also installed and may install
  dependencies from other phases.
  
    after action        requirements that must be met
    ----------------    --------------------------------
    make install        runtime
    Build install
  
  =over
  
  =item configure
  
  The configure phase occurs before any dynamic configuration has been
  attempted.  Libraries required by the configure phase B<must> be
  available for use before the distribution building tool has been
  executed.
  
  =item build
  
  The build phase is when the distribution's source code is compiled (if
  necessary) and otherwise made ready for installation.
  
  =item test
  
  The test phase is when the distribution's automated test suite is run.
  Any library that is needed only for testing and not for subsequent use
  should be listed here.
  
  =item runtime
  
  The runtime phase refers not only to when the distribution's contents
  are installed, but also to its continued use.  Any library that is a
  prerequisite for regular use of this distribution should be indicated
  here.
  
  =item develop
  
  The develop phase's prereqs are libraries needed to work on the
  distribution's source code as its author does.  These tools might be
  needed to build a release tarball, to run author-only tests, or to
  perform other tasks related to developing new versions of the
  distribution.
  
  =back
  
  =head3 Relationships
  
  =over
  
  =item requires
  
  These dependencies B<must> be installed for proper completion of the
  phase.
  
  =item recommends
  
  Recommended dependencies are I<strongly> encouraged and should be
  satisfied except in resource constrained environments.
  
  =item suggests
  
  These dependencies are optional, but are suggested for enhanced operation
  of the described distribution.
  
  =item conflicts
  
  These libraries cannot be installed when the phase is in operation.
  This is a very rare situation, and the C<conflicts> relationship should
  be used with great caution, or not at all.
  
  =back
  
  =head2 Merging and Resolving Prerequisites
  
  Whenever metadata consumers merge prerequisites, either from different
  phases or from C<optional_features>, they should merged in a way which
  preserves the intended semantics of the prerequisite structure.  Generally,
  this means concatenating the version specifications using commas, as
  described in the L<Version Ranges> section.
  
  Another subtle error that can occur in resolving prerequisites comes from
  the way that modules in prerequisites are indexed to distribution files on
  CPAN.  When a module is deleted from a distribution, prerequisites calling
  for that module could indicate an older distribution should be installed,
  potentially overwriting files from a newer distribution.
  
  For example, as of Oct 31, 2009, the CPAN index file contained these
  module-distribution mappings:
  
    Class::MOP                   0.94  D/DR/DROLSKY/Class-MOP-0.94.tar.gz
    Class::MOP::Class            0.94  D/DR/DROLSKY/Class-MOP-0.94.tar.gz
    Class::MOP::Class::Immutable 0.04  S/ST/STEVAN/Class-MOP-0.36.tar.gz
  
  Consider the case where "Class::MOP" 0.94 is installed.  If a
  distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
  it could result in Class-MOP-0.36.tar.gz being installed, overwriting
  any files from Class-MOP-0.94.tar.gz.
  
  Consumers of metadata B<should> test whether prerequisites would result
  in installed module files being "downgraded" to an older version and
  B<may> warn users or ignore the prerequisite that would cause such a
  result.
  
  =head1 SERIALIZATION
  
  Distribution metadata should be serialized (as a hashref) as
  JSON-encoded data and packaged with distributions as the file
  F<META.json>.
  
  In the past, the distribution metadata structure had been packed with
  distributions as F<META.yml>, a file in the YAML Tiny format (for which,
  see L<YAML::Tiny>).  Tools that consume distribution metadata from disk
  should be capable of loading F<META.yml>, but should prefer F<META.json>
  if both are found.
  
  =head1 NOTES FOR IMPLEMENTORS
  
  =head2 Extracting Version Numbers from Perl Modules
  
  To get the version number from a Perl module, consumers should use the
  C<< MM->parse_version($file) >> method provided by
  L<ExtUtils::MakeMaker> or L<Module::Metadata>.  For example, for the
  module given by C<$mod>, the version may be retrieved in one of the
  following ways:
  
    # via ExtUtils::MakeMaker
    my $file = MM->_installed_file_for_module($mod);
    my $version = MM->parse_version($file)
  
  The private C<_installed_file_for_module> method may be replaced with
  other methods for locating a module in C<@INC>.
  
    # via Module::Metadata
    my $info = Module::Metadata->new_from_module($mod);
    my $version = $info->version;
  
  If only a filename is available, the following approach may be used:
  
    # via Module::Build
    my $info = Module::Metadata->new_from_file($file);
    my $version = $info->version;
  
  =head2 Comparing Version Numbers
  
  The L<version> module provides the most reliable way to compare version
  numbers in all the various ways they might be provided or might exist
  within modules.  Given two strings containing version numbers, C<$v1> and
  C<$v2>, they should be converted to C<version> objects before using
  ordinary comparison operators.  For example:
  
    use version;
    if ( version->new($v1) <=> version->new($v2) ) {
      print "Versions are not equal\n";
    }
  
  If the only comparison needed is whether an installed module is of a
  sufficiently high version, a direct test may be done using the string
  form of C<eval> and the C<use> function.  For example, for module C<$mod>
  and version prerequisite C<$prereq>:
  
    if ( eval "use $mod $prereq (); 1" ) {
      print "Module $mod version is OK.\n";
    }
  
  If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
  this presents security implications.
  
  =head2 Prerequisites for dynamically configured distributions
  
  When C<dynamic_config> is true, it is an error to presume that the
  prerequisites given in distribution metadata will have any relationship
  whatsoever to the actual prerequisites of the distribution.
  
  In practice, however, one can generally expect such prerequisites to be
  one of two things:
  
  =over 4
  
  =item *
  
  The minimum prerequisites for the distribution, to which dynamic configuration will only add items
  
  =item *
  
  Whatever the distribution configured with on the releaser's machine at release time
  
  =back
  
  The second case often turns out to have identical results to the first case,
  albeit only by accident.
  
  As such, consumers may use this data for informational analysis, but
  presenting it to the user as canonical or relying on it as such is
  invariably the height of folly.
  
  =head2 Indexing distributions a la PAUSE
  
  While no_index tells you what must be ignored when indexing, this spec holds
  no opinion on how you should get your initial candidate list of things to
  possibly index. For "normal" distributions you might consider simply indexing
  the contents of lib/, but there are many fascinating oddities on CPAN and
  many dists from the days when it was normal to put the main .pm file in the
  root of the distribution archive - so PAUSE currently indexes all .pm and .PL
  files that are not either (a) specifically excluded by no_index (b) in
  C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
  C<perl5>.
  
  Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
  C<t> as well as anything marked as no_index.
  
  Also remember: If the META file contains a provides field, you shouldn't be
  indexing anything in the first place - just use that.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  CPAN, L<http://www.cpan.org/>
  
  =item *
  
  JSON, L<http://json.org/>
  
  =item *
  
  YAML, L<http://www.yaml.org/>
  
  =item *
  
  L<CPAN>
  
  =item *
  
  L<CPANPLUS>
  
  =item *
  
  L<ExtUtils::MakeMaker>
  
  =item *
  
  L<Module::Build>
  
  =item *
  
  L<Module::Install>
  
  =item *
  
  L<CPAN::Meta::History::Meta_1_4>
  
  =back
  
  =head1 HISTORY
  
  Ken Williams wrote the original CPAN Meta Spec (also known as the
  "META.yml spec") in 2003 and maintained it through several revisions
  with input from various members of the community.  In 2005, Randy
  Sims redrafted it from HTML to POD for the version 1.2 release.  Ken
  continued to maintain the spec through version 1.4.
  
  In late 2009, David Golden organized the version 2 proposal review
  process.  David and Ricardo Signes drafted the final version 2 spec
  in April 2010 based on the version 1.4 spec and patches contributed
  during the proposal process.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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_META_SPEC

$fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR';
  use 5.006;
  use strict;
  use warnings;
  package CPAN::Meta::Validator;
  
  our $VERSION = '2.150010';
  
  #pod =head1 SYNOPSIS
  #pod
  #pod   my $struct = decode_json_file('META.json');
  #pod
  #pod   my $cmv = CPAN::Meta::Validator->new( $struct );
  #pod
  #pod   unless ( $cmv->is_valid ) {
  #pod     my $msg = "Invalid META structure.  Errors found:\n";
  #pod     $msg .= join( "\n", $cmv->errors );
  #pod     die $msg;
  #pod   }
  #pod
  #pod =head1 DESCRIPTION
  #pod
  #pod This module validates a CPAN Meta structure against the version of the
  #pod the specification claimed in the C<meta-spec> field of the structure.
  #pod
  #pod =cut
  
  #--------------------------------------------------------------------------#
  # This code copied and adapted from Test::CPAN::Meta
  # by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
  # L<http://www.missbarbell.co.uk>
  #--------------------------------------------------------------------------#
  
  #--------------------------------------------------------------------------#
  # Specification Definitions
  #--------------------------------------------------------------------------#
  
  my %known_specs = (
      '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
      '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
      '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
      '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
      '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
  );
  my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
  
  my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
  
  my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version   } } };
  
  my $no_index_2 = {
      'map'       => { file       => { list => { value => \&string } },
                       directory  => { list => { value => \&string } },
                       'package'  => { list => { value => \&string } },
                       namespace  => { list => { value => \&string } },
                      ':key'      => { name => \&custom_2, value => \&anything },
      }
  };
  
  my $no_index_1_3 = {
      'map'       => { file       => { list => { value => \&string } },
                       directory  => { list => { value => \&string } },
                       'package'  => { list => { value => \&string } },
                       namespace  => { list => { value => \&string } },
                       ':key'     => { name => \&string, value => \&anything },
      }
  };
  
  my $no_index_1_2 = {
      'map'       => { file       => { list => { value => \&string } },
                       dir        => { list => { value => \&string } },
                       'package'  => { list => { value => \&string } },
                       namespace  => { list => { value => \&string } },
                       ':key'     => { name => \&string, value => \&anything },
      }
  };
  
  my $no_index_1_1 = {
      'map'       => { ':key'     => { name => \&string, list => { value => \&string } },
      }
  };
  
  my $prereq_map = {
    map => {
      ':key' => {
        name => \&phase,
        'map' => {
          ':key'  => {
            name => \&relation,
            %$module_map1,
          },
        },
      }
    },
  };
  
  my %definitions = (
    '2' => {
      # REQUIRED
      'abstract'            => { mandatory => 1, value => \&string  },
      'author'              => { mandatory => 1, list => { value => \&string } },
      'dynamic_config'      => { mandatory => 1, value => \&boolean },
      'generated_by'        => { mandatory => 1, value => \&string  },
      'license'             => { mandatory => 1, list => { value => \&license } },
      'meta-spec' => {
        mandatory => 1,
        'map' => {
          version => { mandatory => 1, value => \&version},
          url     => { value => \&url },
          ':key' => { name => \&custom_2, value => \&anything },
        }
      },
      'name'                => { mandatory => 1, value => \&string  },
      'release_status'      => { mandatory => 1, value => \&release_status },
      'version'             => { mandatory => 1, value => \&version },
  
      # OPTIONAL
      'description' => { value => \&string },
      'keywords'    => { list => { value => \&string } },
      'no_index'    => $no_index_2,
      'optional_features'   => {
        'map'       => {
          ':key'  => {
            name => \&string,
            'map'   => {
              description        => { value => \&string },
              prereqs => $prereq_map,
              ':key' => { name => \&custom_2, value => \&anything },
            }
          }
        }
      },
      'prereqs' => $prereq_map,
      'provides'    => {
        'map'       => {
          ':key' => {
            name  => \&module,
            'map' => {
              file    => { mandatory => 1, value => \&file },
              version => { value => \&version },
              ':key' => { name => \&custom_2, value => \&anything },
            }
          }
        }
      },
      'resources'   => {
        'map'       => {
          license    => { list => { value => \&url } },
          homepage   => { value => \&url },
          bugtracker => {
            'map' => {
              web => { value => \&url },
              mailto => { value => \&string},
              ':key' => { name => \&custom_2, value => \&anything },
            }
          },
          repository => {
            'map' => {
              web => { value => \&url },
              url => { value => \&url },
              type => { value => \&string },
              ':key' => { name => \&custom_2, value => \&anything },
            }
          },
          ':key'     => { value => \&string, name => \&custom_2 },
        }
      },
  
      # CUSTOM -- additional user defined key/value pairs
      # note we can only validate the key name, as the structure is user defined
      ':key'        => { name => \&custom_2, value => \&anything },
    },
  
  '1.4' => {
    'meta-spec'           => {
      mandatory => 1,
      'map' => {
        version => { mandatory => 1, value => \&version},
        url     => { mandatory => 1, value => \&urlspec },
        ':key'  => { name => \&string, value => \&anything },
      },
    },
  
    'name'                => { mandatory => 1, value => \&string  },
    'version'             => { mandatory => 1, value => \&version },
    'abstract'            => { mandatory => 1, value => \&string  },
    'author'              => { mandatory => 1, list  => { value => \&string } },
    'license'             => { mandatory => 1, value => \&license },
    'generated_by'        => { mandatory => 1, value => \&string  },
  
    'distribution_type'   => { value => \&string  },
    'dynamic_config'      => { value => \&boolean },
  
    'requires'            => $module_map1,
    'recommends'          => $module_map1,
    'build_requires'      => $module_map1,
    'configure_requires'  => $module_map1,
    'conflicts'           => $module_map2,
  
    'optional_features'   => {
      'map'       => {
          ':key'  => { name => \&string,
              'map'   => { description        => { value => \&string },
                           requires           => $module_map1,
                           recommends         => $module_map1,
                           build_requires     => $module_map1,
                           conflicts          => $module_map2,
                           ':key'  => { name => \&string, value => \&anything },
              }
          }
       }
    },
  
    'provides'    => {
      'map'       => {
        ':key' => { name  => \&module,
          'map' => {
            file    => { mandatory => 1, value => \&file },
            version => { value => \&version },
            ':key'  => { name => \&string, value => \&anything },
          }
        }
      }
    },
  
    'no_index'    => $no_index_1_3,
    'private'     => $no_index_1_3,
  
    'keywords'    => { list => { value => \&string } },
  
    'resources'   => {
      'map'       => { license    => { value => \&url },
                       homepage   => { value => \&url },
                       bugtracker => { value => \&url },
                       repository => { value => \&url },
                       ':key'     => { value => \&string, name => \&custom_1 },
      }
    },
  
    # additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&string, value => \&anything },
  },
  
  '1.3' => {
    'meta-spec'           => {
      mandatory => 1,
      'map' => {
        version => { mandatory => 1, value => \&version},
        url     => { mandatory => 1, value => \&urlspec },
        ':key'  => { name => \&string, value => \&anything },
      },
    },
  
    'name'                => { mandatory => 1, value => \&string  },
    'version'             => { mandatory => 1, value => \&version },
    'abstract'            => { mandatory => 1, value => \&string  },
    'author'              => { mandatory => 1, list  => { value => \&string } },
    'license'             => { mandatory => 1, value => \&license },
    'generated_by'        => { mandatory => 1, value => \&string  },
  
    'distribution_type'   => { value => \&string  },
    'dynamic_config'      => { value => \&boolean },
  
    'requires'            => $module_map1,
    'recommends'          => $module_map1,
    'build_requires'      => $module_map1,
    'conflicts'           => $module_map2,
  
    'optional_features'   => {
      'map'       => {
          ':key'  => { name => \&string,
              'map'   => { description        => { value => \&string },
                           requires           => $module_map1,
                           recommends         => $module_map1,
                           build_requires     => $module_map1,
                           conflicts          => $module_map2,
                           ':key'  => { name => \&string, value => \&anything },
              }
          }
       }
    },
  
    'provides'    => {
      'map'       => {
        ':key' => { name  => \&module,
          'map' => {
            file    => { mandatory => 1, value => \&file },
            version => { value => \&version },
            ':key'  => { name => \&string, value => \&anything },
          }
        }
      }
    },
  
  
    'no_index'    => $no_index_1_3,
    'private'     => $no_index_1_3,
  
    'keywords'    => { list => { value => \&string } },
  
    'resources'   => {
      'map'       => { license    => { value => \&url },
                       homepage   => { value => \&url },
                       bugtracker => { value => \&url },
                       repository => { value => \&url },
                       ':key'     => { value => \&string, name => \&custom_1 },
      }
    },
  
    # additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&string, value => \&anything },
  },
  
  # v1.2 is misleading, it seems to assume that a number of fields where created
  # within v1.1, when they were created within v1.2. This may have been an
  # original mistake, and that a v1.1 was retro fitted into the timeline, when
  # v1.2 was originally slated as v1.1. But I could be wrong ;)
  '1.2' => {
    'meta-spec'           => {
      mandatory => 1,
      'map' => {
        version => { mandatory => 1, value => \&version},
        url     => { mandatory => 1, value => \&urlspec },
        ':key'  => { name => \&string, value => \&anything },
      },
    },
  
  
    'name'                => { mandatory => 1, value => \&string  },
    'version'             => { mandatory => 1, value => \&version },
    'license'             => { mandatory => 1, value => \&license },
    'generated_by'        => { mandatory => 1, value => \&string  },
    'author'              => { mandatory => 1, list => { value => \&string } },
    'abstract'            => { mandatory => 1, value => \&string  },
  
    'distribution_type'   => { value => \&string  },
    'dynamic_config'      => { value => \&boolean },
  
    'keywords'            => { list => { value => \&string } },
  
    'private'             => $no_index_1_2,
    '$no_index'           => $no_index_1_2,
  
    'requires'            => $module_map1,
    'recommends'          => $module_map1,
    'build_requires'      => $module_map1,
    'conflicts'           => $module_map2,
  
    'optional_features'   => {
      'map'       => {
          ':key'  => { name => \&string,
              'map'   => { description        => { value => \&string },
                           requires           => $module_map1,
                           recommends         => $module_map1,
                           build_requires     => $module_map1,
                           conflicts          => $module_map2,
                           ':key'  => { name => \&string, value => \&anything },
              }
          }
       }
    },
  
    'provides'    => {
      'map'       => {
        ':key' => { name  => \&module,
          'map' => {
            file    => { mandatory => 1, value => \&file },
            version => { value => \&version },
            ':key'  => { name => \&string, value => \&anything },
          }
        }
      }
    },
  
    'resources'   => {
      'map'       => { license    => { value => \&url },
                       homepage   => { value => \&url },
                       bugtracker => { value => \&url },
                       repository => { value => \&url },
                       ':key'     => { value => \&string, name => \&custom_1 },
      }
    },
  
    # additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&string, value => \&anything },
  },
  
  # note that the 1.1 spec only specifies 'version' as mandatory
  '1.1' => {
    'name'                => { value => \&string  },
    'version'             => { mandatory => 1, value => \&version },
    'license'             => { value => \&license },
    'generated_by'        => { value => \&string  },
  
    'license_uri'         => { value => \&url },
    'distribution_type'   => { value => \&string  },
    'dynamic_config'      => { value => \&boolean },
  
    'private'             => $no_index_1_1,
  
    'requires'            => $module_map1,
    'recommends'          => $module_map1,
    'build_requires'      => $module_map1,
    'conflicts'           => $module_map2,
  
    # additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&string, value => \&anything },
  },
  
  # note that the 1.0 spec doesn't specify optional or mandatory fields
  # but we will treat version as mandatory since otherwise META 1.0 is
  # completely arbitrary and pointless
  '1.0' => {
    'name'                => { value => \&string  },
    'version'             => { mandatory => 1, value => \&version },
    'license'             => { value => \&license },
    'generated_by'        => { value => \&string  },
  
    'license_uri'         => { value => \&url },
    'distribution_type'   => { value => \&string  },
    'dynamic_config'      => { value => \&boolean },
  
    'requires'            => $module_map1,
    'recommends'          => $module_map1,
    'build_requires'      => $module_map1,
    'conflicts'           => $module_map2,
  
    # additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&string, value => \&anything },
  },
  );
  
  #--------------------------------------------------------------------------#
  # Code
  #--------------------------------------------------------------------------#
  
  #pod =method new
  #pod
  #pod   my $cmv = CPAN::Meta::Validator->new( $struct )
  #pod
  #pod The constructor must be passed a metadata structure.
  #pod
  #pod =cut
  
  sub new {
    my ($class,$data) = @_;
  
    # create an attributes hash
    my $self = {
      'data'    => $data,
      'spec'    => eval { $data->{'meta-spec'}{'version'} } || "1.0",
      'errors'  => undef,
    };
  
    # create the object
    return bless $self, $class;
  }
  
  #pod =method is_valid
  #pod
  #pod   if ( $cmv->is_valid ) {
  #pod     ...
  #pod   }
  #pod
  #pod Returns a boolean value indicating whether the metadata provided
  #pod is valid.
  #pod
  #pod =cut
  
  sub is_valid {
      my $self = shift;
      my $data = $self->{data};
      my $spec_version = $self->{spec};
      $self->check_map($definitions{$spec_version},$data);
      return ! $self->errors;
  }
  
  #pod =method errors
  #pod
  #pod   warn( join "\n", $cmv->errors );
  #pod
  #pod Returns a list of errors seen during validation.
  #pod
  #pod =cut
  
  sub errors {
      my $self = shift;
      return ()   unless(defined $self->{errors});
      return @{$self->{errors}};
  }
  
  #pod =begin :internals
  #pod
  #pod =head2 Check Methods
  #pod
  #pod =over
  #pod
  #pod =item *
  #pod
  #pod check_map($spec,$data)
  #pod
  #pod Checks whether a map (or hash) part of the data structure conforms to the
  #pod appropriate specification definition.
  #pod
  #pod =item *
  #pod
  #pod check_list($spec,$data)
  #pod
  #pod Checks whether a list (or array) part of the data structure conforms to
  #pod the appropriate specification definition.
  #pod
  #pod =item *
  #pod
  #pod =back
  #pod
  #pod =cut
  
  my $spec_error = "Missing validation action in specification. "
    . "Must be one of 'map', 'list', or 'value'";
  
  sub check_map {
      my ($self,$spec,$data) = @_;
  
      if(ref($spec) ne 'HASH') {
          $self->_error( "Unknown META specification, cannot validate." );
          return;
      }
  
      if(ref($data) ne 'HASH') {
          $self->_error( "Expected a map structure from string or file." );
          return;
      }
  
      for my $key (keys %$spec) {
          next    unless($spec->{$key}->{mandatory});
          next    if(defined $data->{$key});
          push @{$self->{stack}}, $key;
          $self->_error( "Missing mandatory field, '$key'" );
          pop @{$self->{stack}};
      }
  
      for my $key (keys %$data) {
          push @{$self->{stack}}, $key;
          if($spec->{$key}) {
              if($spec->{$key}{value}) {
                  $spec->{$key}{value}->($self,$key,$data->{$key});
              } elsif($spec->{$key}{'map'}) {
                  $self->check_map($spec->{$key}{'map'},$data->{$key});
              } elsif($spec->{$key}{'list'}) {
                  $self->check_list($spec->{$key}{'list'},$data->{$key});
              } else {
                  $self->_error( "$spec_error for '$key'" );
              }
  
          } elsif ($spec->{':key'}) {
              $spec->{':key'}{name}->($self,$key,$key);
              if($spec->{':key'}{value}) {
                  $spec->{':key'}{value}->($self,$key,$data->{$key});
              } elsif($spec->{':key'}{'map'}) {
                  $self->check_map($spec->{':key'}{'map'},$data->{$key});
              } elsif($spec->{':key'}{'list'}) {
                  $self->check_list($spec->{':key'}{'list'},$data->{$key});
              } else {
                  $self->_error( "$spec_error for ':key'" );
              }
  
  
          } else {
              $self->_error( "Unknown key, '$key', found in map structure" );
          }
          pop @{$self->{stack}};
      }
  }
  
  sub check_list {
      my ($self,$spec,$data) = @_;
  
      if(ref($data) ne 'ARRAY') {
          $self->_error( "Expected a list structure" );
          return;
      }
  
      if(defined $spec->{mandatory}) {
          if(!defined $data->[0]) {
              $self->_error( "Missing entries from mandatory list" );
          }
      }
  
      for my $value (@$data) {
          push @{$self->{stack}}, $value || "<undef>";
          if(defined $spec->{value}) {
              $spec->{value}->($self,'list',$value);
          } elsif(defined $spec->{'map'}) {
              $self->check_map($spec->{'map'},$value);
          } elsif(defined $spec->{'list'}) {
              $self->check_list($spec->{'list'},$value);
          } elsif ($spec->{':key'}) {
              $self->check_map($spec,$value);
          } else {
            $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
          }
          pop @{$self->{stack}};
      }
  }
  
  #pod =head2 Validator Methods
  #pod
  #pod =over
  #pod
  #pod =item *
  #pod
  #pod header($self,$key,$value)
  #pod
  #pod Validates that the header is valid.
  #pod
  #pod Note: No longer used as we now read the data structure, not the file.
  #pod
  #pod =item *
  #pod
  #pod url($self,$key,$value)
  #pod
  #pod Validates that a given value is in an acceptable URL format
  #pod
  #pod =item *
  #pod
  #pod urlspec($self,$key,$value)
  #pod
  #pod Validates that the URL to a META specification is a known one.
  #pod
  #pod =item *
  #pod
  #pod string_or_undef($self,$key,$value)
  #pod
  #pod Validates that the value is either a string or an undef value. Bit of a
  #pod catchall function for parts of the data structure that are completely user
  #pod defined.
  #pod
  #pod =item *
  #pod
  #pod string($self,$key,$value)
  #pod
  #pod Validates that a string exists for the given key.
  #pod
  #pod =item *
  #pod
  #pod file($self,$key,$value)
  #pod
  #pod Validate that a file is passed for the given key. This may be made more
  #pod thorough in the future. For now it acts like \&string.
  #pod
  #pod =item *
  #pod
  #pod exversion($self,$key,$value)
  #pod
  #pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
  #pod
  #pod =item *
  #pod
  #pod version($self,$key,$value)
  #pod
  #pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
  #pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
  #pod
  #pod =item *
  #pod
  #pod boolean($self,$key,$value)
  #pod
  #pod Validates for a boolean value: a defined value that is either "1" or "0" or
  #pod stringifies to those values.
  #pod
  #pod =item *
  #pod
  #pod license($self,$key,$value)
  #pod
  #pod Validates that a value is given for the license. Returns 1 if an known license
  #pod type, or 2 if a value is given but the license type is not a recommended one.
  #pod
  #pod =item *
  #pod
  #pod custom_1($self,$key,$value)
  #pod
  #pod Validates that the given key is in CamelCase, to indicate a user defined
  #pod keyword and only has characters in the class [-_a-zA-Z].  In version 1.X
  #pod of the spec, this was only explicitly stated for 'resources'.
  #pod
  #pod =item *
  #pod
  #pod custom_2($self,$key,$value)
  #pod
  #pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
  #pod defined keyword and only has characters in the class [-_a-zA-Z]
  #pod
  #pod =item *
  #pod
  #pod identifier($self,$key,$value)
  #pod
  #pod Validates that key is in an acceptable format for the META specification,
  #pod for an identifier, i.e. any that matches the regular expression
  #pod qr/[a-z][a-z_]/i.
  #pod
  #pod =item *
  #pod
  #pod module($self,$key,$value)
  #pod
  #pod Validates that a given key is in an acceptable module name format, e.g.
  #pod 'Test::CPAN::Meta::Version'.
  #pod
  #pod =back
  #pod
  #pod =end :internals
  #pod
  #pod =cut
  
  sub header {
      my ($self,$key,$value) = @_;
      if(defined $value) {
          return 1    if($value && $value =~ /^--- #YAML:1.0/);
      }
      $self->_error( "file does not have a valid YAML header." );
      return 0;
  }
  
  sub release_status {
    my ($self,$key,$value) = @_;
    if(defined $value) {
      my $version = $self->{data}{version} || '';
      if ( $version =~ /_/ ) {
        return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
        $self->_error( "'$value' for '$key' is invalid for version '$version'" );
      }
      else {
        return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
        $self->_error( "'$value' for '$key' is invalid" );
      }
    }
    else {
      $self->_error( "'$key' is not defined" );
    }
    return 0;
  }
  
  # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
  sub _uri_split {
       return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
  }
  
  sub url {
      my ($self,$key,$value) = @_;
      if(defined $value) {
        my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
        unless ( defined $scheme && length $scheme ) {
          $self->_error( "'$value' for '$key' does not have a URL scheme" );
          return 0;
        }
        unless ( defined $auth && length $auth ) {
          $self->_error( "'$value' for '$key' does not have a URL authority" );
          return 0;
        }
        return 1;
      }
      $value ||= '';
      $self->_error( "'$value' for '$key' is not a valid URL." );
      return 0;
  }
  
  sub urlspec {
      my ($self,$key,$value) = @_;
      if(defined $value) {
          return 1    if($value && $known_specs{$self->{spec}} eq $value);
          if($value && $known_urls{$value}) {
              $self->_error( 'META specification URL does not match version' );
              return 0;
          }
      }
      $self->_error( 'Unknown META specification' );
      return 0;
  }
  
  sub anything { return 1 }
  
  sub string {
      my ($self,$key,$value) = @_;
      if(defined $value) {
          return 1    if($value || $value =~ /^0$/);
      }
      $self->_error( "value is an undefined string" );
      return 0;
  }
  
  sub string_or_undef {
      my ($self,$key,$value) = @_;
      return 1    unless(defined $value);
      return 1    if($value || $value =~ /^0$/);
      $self->_error( "No string defined for '$key'" );
      return 0;
  }
  
  sub file {
      my ($self,$key,$value) = @_;
      return 1    if(defined $value);
      $self->_error( "No file defined for '$key'" );
      return 0;
  }
  
  sub exversion {
      my ($self,$key,$value) = @_;
      if(defined $value && ($value || $value =~ /0/)) {
          my $pass = 1;
          for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
          return $pass;
      }
      $value = '<undef>'  unless(defined $value);
      $self->_error( "'$value' for '$key' is not a valid version." );
      return 0;
  }
  
  sub version {
      my ($self,$key,$value) = @_;
      if(defined $value) {
          return 0    unless($value || $value =~ /0/);
          return 1    if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
      } else {
          $value = '<undef>';
      }
      $self->_error( "'$value' for '$key' is not a valid version." );
      return 0;
  }
  
  sub boolean {
      my ($self,$key,$value) = @_;
      if(defined $value) {
          return 1    if($value =~ /^(0|1)$/);
      } else {
          $value = '<undef>';
      }
      $self->_error( "'$value' for '$key' is not a boolean value." );
      return 0;
  }
  
  my %v1_licenses = (
      'perl'         => 'http://dev.perl.org/licenses/',
      'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
      'apache'       => 'http://apache.org/licenses/LICENSE-2.0',
      'artistic'     => 'http://opensource.org/licenses/artistic-license.php',
      'artistic_2'   => 'http://opensource.org/licenses/artistic-license-2.0.php',
      'lgpl'         => 'http://www.opensource.org/licenses/lgpl-license.php',
      'bsd'          => 'http://www.opensource.org/licenses/bsd-license.php',
      'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
      'mit'          => 'http://opensource.org/licenses/mit-license.php',
      'mozilla'      => 'http://opensource.org/licenses/mozilla1.1.php',
      'open_source'  => undef,
      'unrestricted' => undef,
      'restrictive'  => undef,
      'unknown'      => undef,
  );
  
  my %v2_licenses = map { $_ => 1 } qw(
    agpl_3
    apache_1_1
    apache_2_0
    artistic_1
    artistic_2
    bsd
    freebsd
    gfdl_1_2
    gfdl_1_3
    gpl_1
    gpl_2
    gpl_3
    lgpl_2_1
    lgpl_3_0
    mit
    mozilla_1_0
    mozilla_1_1
    openssl
    perl_5
    qpl_1_0
    ssleay
    sun
    zlib
    open_source
    restricted
    unrestricted
    unknown
  );
  
  sub license {
      my ($self,$key,$value) = @_;
      my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
      if(defined $value) {
          return 1    if($value && exists $licenses->{$value});
      } else {
          $value = '<undef>';
      }
      $self->_error( "License '$value' is invalid" );
      return 0;
  }
  
  sub custom_1 {
      my ($self,$key) = @_;
      if(defined $key) {
          # a valid user defined key should be alphabetic
          # and contain at least one capital case letter.
          return 1    if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
      } else {
          $key = '<undef>';
      }
      $self->_error( "Custom resource '$key' must be in CamelCase." );
      return 0;
  }
  
  sub custom_2 {
      my ($self,$key) = @_;
      if(defined $key) {
          return 1    if($key && $key =~ /^x_/i);  # user defined
      } else {
          $key = '<undef>';
      }
      $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
      return 0;
  }
  
  sub identifier {
      my ($self,$key) = @_;
      if(defined $key) {
          return 1    if($key && $key =~ /^([a-z][_a-z]+)$/i);    # spec 2.0 defined
      } else {
          $key = '<undef>';
      }
      $self->_error( "Key '$key' is not a legal identifier." );
      return 0;
  }
  
  sub module {
      my ($self,$key) = @_;
      if(defined $key) {
          return 1    if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
      } else {
          $key = '<undef>';
      }
      $self->_error( "Key '$key' is not a legal module name." );
      return 0;
  }
  
  my @valid_phases = qw/ configure build test runtime develop /;
  sub phase {
      my ($self,$key) = @_;
      if(defined $key) {
          return 1 if( length $key && grep { $key eq $_ } @valid_phases );
          return 1 if $key =~ /x_/i;
      } else {
          $key = '<undef>';
      }
      $self->_error( "Key '$key' is not a legal phase." );
      return 0;
  }
  
  my @valid_relations = qw/ requires recommends suggests conflicts /;
  sub relation {
      my ($self,$key) = @_;
      if(defined $key) {
          return 1 if( length $key && grep { $key eq $_ } @valid_relations );
          return 1 if $key =~ /x_/i;
      } else {
          $key = '<undef>';
      }
      $self->_error( "Key '$key' is not a legal prereq relationship." );
      return 0;
  }
  
  sub _error {
      my $self = shift;
      my $mess = shift;
  
      $mess .= ' ('.join(' -> ',@{$self->{stack}}).')'  if($self->{stack});
      $mess .= " [Validation: $self->{spec}]";
  
      push @{$self->{errors}}, $mess;
  }
  
  1;
  
  # ABSTRACT: validate CPAN distribution metadata structures
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::Validator - validate CPAN distribution metadata structures
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 SYNOPSIS
  
    my $struct = decode_json_file('META.json');
  
    my $cmv = CPAN::Meta::Validator->new( $struct );
  
    unless ( $cmv->is_valid ) {
      my $msg = "Invalid META structure.  Errors found:\n";
      $msg .= join( "\n", $cmv->errors );
      die $msg;
    }
  
  =head1 DESCRIPTION
  
  This module validates a CPAN Meta structure against the version of the
  the specification claimed in the C<meta-spec> field of the structure.
  
  =head1 METHODS
  
  =head2 new
  
    my $cmv = CPAN::Meta::Validator->new( $struct )
  
  The constructor must be passed a metadata structure.
  
  =head2 is_valid
  
    if ( $cmv->is_valid ) {
      ...
    }
  
  Returns a boolean value indicating whether the metadata provided
  is valid.
  
  =head2 errors
  
    warn( join "\n", $cmv->errors );
  
  Returns a list of errors seen during validation.
  
  =begin :internals
  
  =head2 Check Methods
  
  =over
  
  =item *
  
  check_map($spec,$data)
  
  Checks whether a map (or hash) part of the data structure conforms to the
  appropriate specification definition.
  
  =item *
  
  check_list($spec,$data)
  
  Checks whether a list (or array) part of the data structure conforms to
  the appropriate specification definition.
  
  =item *
  
  =back
  
  =head2 Validator Methods
  
  =over
  
  =item *
  
  header($self,$key,$value)
  
  Validates that the header is valid.
  
  Note: No longer used as we now read the data structure, not the file.
  
  =item *
  
  url($self,$key,$value)
  
  Validates that a given value is in an acceptable URL format
  
  =item *
  
  urlspec($self,$key,$value)
  
  Validates that the URL to a META specification is a known one.
  
  =item *
  
  string_or_undef($self,$key,$value)
  
  Validates that the value is either a string or an undef value. Bit of a
  catchall function for parts of the data structure that are completely user
  defined.
  
  =item *
  
  string($self,$key,$value)
  
  Validates that a string exists for the given key.
  
  =item *
  
  file($self,$key,$value)
  
  Validate that a file is passed for the given key. This may be made more
  thorough in the future. For now it acts like \&string.
  
  =item *
  
  exversion($self,$key,$value)
  
  Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
  
  =item *
  
  version($self,$key,$value)
  
  Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
  are both valid. A leading 'v' like 'v1.2.3' is also valid.
  
  =item *
  
  boolean($self,$key,$value)
  
  Validates for a boolean value: a defined value that is either "1" or "0" or
  stringifies to those values.
  
  =item *
  
  license($self,$key,$value)
  
  Validates that a value is given for the license. Returns 1 if an known license
  type, or 2 if a value is given but the license type is not a recommended one.
  
  =item *
  
  custom_1($self,$key,$value)
  
  Validates that the given key is in CamelCase, to indicate a user defined
  keyword and only has characters in the class [-_a-zA-Z].  In version 1.X
  of the spec, this was only explicitly stated for 'resources'.
  
  =item *
  
  custom_2($self,$key,$value)
  
  Validates that the given key begins with 'x_' or 'X_', to indicate a user
  defined keyword and only has characters in the class [-_a-zA-Z]
  
  =item *
  
  identifier($self,$key,$value)
  
  Validates that key is in an acceptable format for the META specification,
  for an identifier, i.e. any that matches the regular expression
  qr/[a-z][a-z_]/i.
  
  =item *
  
  module($self,$key,$value)
  
  Validates that a given key is in an acceptable module name format, e.g.
  'Test::CPAN::Meta::Version'.
  
  =back
  
  =end :internals
  
  =for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
  identifier license module phase relation release_status string string_or_undef
  url urlspec version header check_map
  
  =head1 BUGS
  
  Please report any bugs or feature using the CPAN Request Tracker.
  Bugs can be submitted through the web interface at
  L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
  
  When submitting a bug or request, please include a test-file or a patch to an
  existing test-file that illustrates the bug or desired feature.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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
  
  __END__
  
  
  # vim: ts=2 sts=2 sw=2 et :
CPAN_META_VALIDATOR

$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML';
  use 5.008001; # sane UTF-8 support
  use strict;
  use warnings;
  package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
  # XXX-INGY is 5.8.1 too old/broken for utf8?
  # XXX-XDG Lancaster consensus was that it was sufficient until
  # proven otherwise
  $CPAN::Meta::YAML::VERSION = '0.018';
  ; # original $VERSION removed by Doppelgaenger
  
  #####################################################################
  # The CPAN::Meta::YAML API.
  #
  # These are the currently documented API functions/methods and
  # exports:
  
  use Exporter;
  our @ISA       = qw{ Exporter  };
  our @EXPORT    = qw{ Load Dump };
  our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
  
  ###
  # Functional/Export API:
  
  sub Dump {
      return CPAN::Meta::YAML->new(@_)->_dump_string;
  }
  
  # XXX-INGY Returning last document seems a bad behavior.
  # XXX-XDG I think first would seem more natural, but I don't know
  # that it's worth changing now
  sub Load {
      my $self = CPAN::Meta::YAML->_load_string(@_);
      if ( wantarray ) {
          return @$self;
      } else {
          # To match YAML.pm, return the last document
          return $self->[-1];
      }
  }
  
  # XXX-INGY Do we really need freeze and thaw?
  # XXX-XDG I don't think so.  I'd support deprecating them.
  BEGIN {
      *freeze = \&Dump;
      *thaw   = \&Load;
  }
  
  sub DumpFile {
      my $file = shift;
      return CPAN::Meta::YAML->new(@_)->_dump_file($file);
  }
  
  sub LoadFile {
      my $file = shift;
      my $self = CPAN::Meta::YAML->_load_file($file);
      if ( wantarray ) {
          return @$self;
      } else {
          # Return only the last document to match YAML.pm,
          return $self->[-1];
      }
  }
  
  
  ###
  # Object Oriented API:
  
  # Create an empty CPAN::Meta::YAML object
  # XXX-INGY Why do we use ARRAY object?
  # NOTE: I get it now, but I think it's confusing and not needed.
  # Will change it on a branch later, for review.
  #
  # XXX-XDG I don't support changing it yet.  It's a very well-documented
  # "API" of CPAN::Meta::YAML.  I'd support deprecating it, but Adam suggested
  # we not change it until YAML.pm's own OO API is established so that
  # users only have one API change to digest, not two
  sub new {
      my $class = shift;
      bless [ @_ ], $class;
  }
  
  # XXX-INGY It probably doesn't matter, and it's probably too late to
  # change, but 'read/write' are the wrong names. Read and Write
  # are actions that take data from storage to memory
  # characters/strings. These take the data to/from storage to native
  # Perl objects, which the terms dump and load are meant. As long as
  # this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
  # to add new {read,write}_* methods to this API.
  
  sub read_string {
      my $self = shift;
      $self->_load_string(@_);
  }
  
  sub write_string {
      my $self = shift;
      $self->_dump_string(@_);
  }
  
  sub read {
      my $self = shift;
      $self->_load_file(@_);
  }
  
  sub write {
      my $self = shift;
      $self->_dump_file(@_);
  }
  
  
  
  
  #####################################################################
  # Constants
  
  # Printed form of the unprintable characters in the lowest range
  # of ASCII characters, listed by ASCII ordinal position.
  my @UNPRINTABLE = qw(
      0    x01  x02  x03  x04  x05  x06  a
      b    t    n    v    f    r    x0E  x0F
      x10  x11  x12  x13  x14  x15  x16  x17
      x18  x19  x1A  e    x1C  x1D  x1E  x1F
  );
  
  # Printable characters for escapes
  my %UNESCAPES = (
      0 => "\x00", z => "\x00", N    => "\x85",
      a => "\x07", b => "\x08", t    => "\x09",
      n => "\x0a", v => "\x0b", f    => "\x0c",
      r => "\x0d", e => "\x1b", '\\' => '\\',
  );
  
  # XXX-INGY
  # I(ngy) need to decide if these values should be quoted in
  # CPAN::Meta::YAML or not. Probably yes.
  
  # These 3 values have special meaning when unquoted and using the
  # default YAML schema. They need quotes if they are strings.
  my %QUOTE = map { $_ => 1 } qw{
      null true false
  };
  
  # The commented out form is simpler, but overloaded the Perl regex
  # engine due to recursion and backtracking problems on strings
  # larger than 32,000ish characters. Keep it for reference purposes.
  # qr/\"((?:\\.|[^\"])*)\"/
  my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
  my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
  # unquoted re gets trailing space that needs to be stripped
  my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
  my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
  my $re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;
  
  
  
  
  
  #####################################################################
  # CPAN::Meta::YAML Implementation.
  #
  # These are the private methods that do all the work. They may change
  # at any time.
  
  
  ###
  # Loader functions:
  
  # Create an object from a file
  sub _load_file {
      my $class = ref $_[0] ? ref shift : shift;
  
      # Check the file
      my $file = shift or $class->_error( 'You did not specify a file name' );
      $class->_error( "File '$file' does not exist" )
          unless -e $file;
      $class->_error( "'$file' is a directory, not a file" )
          unless -f _;
      $class->_error( "Insufficient permissions to read '$file'" )
          unless -r _;
  
      # Open unbuffered with strict UTF-8 decoding and no translation layers
      open( my $fh, "<:unix:encoding(UTF-8)", $file );
      unless ( $fh ) {
          $class->_error("Failed to open file '$file': $!");
      }
  
      # flock if available (or warn if not possible for OS-specific reasons)
      if ( _can_flock() ) {
          flock( $fh, Fcntl::LOCK_SH() )
              or warn "Couldn't lock '$file' for reading: $!";
      }
  
      # slurp the contents
      my $contents = eval {
          use warnings FATAL => 'utf8';
          local $/;
          <$fh>
      };
      if ( my $err = $@ ) {
          $class->_error("Error reading from file '$file': $err");
      }
  
      # close the file (release the lock)
      unless ( close $fh ) {
          $class->_error("Failed to close file '$file': $!");
      }
  
      $class->_load_string( $contents );
  }
  
  # Create an object from a string
  sub _load_string {
      my $class  = ref $_[0] ? ref shift : shift;
      my $self   = bless [], $class;
      my $string = $_[0];
      eval {
          unless ( defined $string ) {
              die \"Did not provide a string to load";
          }
  
          # Check if Perl has it marked as characters, but it's internally
          # inconsistent.  E.g. maybe latin1 got read on a :utf8 layer
          if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
              die \<<'...';
  Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
  Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
  ...
          }
  
          # Ensure Unicode character semantics, even for 0x80-0xff
          utf8::upgrade($string);
  
          # Check for and strip any leading UTF-8 BOM
          $string =~ s/^\x{FEFF}//;
  
          # Check for some special cases
          return $self unless length $string;
  
          # Split the file into lines
          my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
                  split /(?:\015{1,2}\012|\015|\012)/, $string;
  
          # Strip the initial YAML header
          @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
  
          # A nibbling parser
          my $in_document = 0;
          while ( @lines ) {
              # Do we have a document header?
              if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
                  # Handle scalar documents
                  shift @lines;
                  if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
                      push @$self,
                          $self->_load_scalar( "$1", [ undef ], \@lines );
                      next;
                  }
                  $in_document = 1;
              }
  
              if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
                  # A naked document
                  push @$self, undef;
                  while ( @lines and $lines[0] !~ /^---/ ) {
                      shift @lines;
                  }
                  $in_document = 0;
  
              # XXX The final '-+$' is to look for -- which ends up being an
              # error later.
              } elsif ( ! $in_document && @$self ) {
                  # only the first document can be explicit
                  die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
              } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
                  # An array at the root
                  my $document = [ ];
                  push @$self, $document;
                  $self->_load_array( $document, [ 0 ], \@lines );
  
              } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
                  # A hash at the root
                  my $document = { };
                  push @$self, $document;
                  $self->_load_hash( $document, [ length($1) ], \@lines );
  
              } else {
                  # Shouldn't get here.  @lines have whitespace-only lines
                  # stripped, and previous match is a line with any
                  # non-whitespace.  So this clause should only be reachable via
                  # a perlbug where \s is not symmetric with \S
  
                  # uncoverable statement
                  die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
              }
          }
      };
      my $err = $@;
      if ( ref $err eq 'SCALAR' ) {
          $self->_error(${$err});
      } elsif ( $err ) {
          $self->_error($err);
      }
  
      return $self;
  }
  
  sub _unquote_single {
      my ($self, $string) = @_;
      return '' unless length $string;
      $string =~ s/\'\'/\'/g;
      return $string;
  }
  
  sub _unquote_double {
      my ($self, $string) = @_;
      return '' unless length $string;
      $string =~ s/\\"/"/g;
      $string =~
          s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
           {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
      return $string;
  }
  
  # Load a YAML scalar string to the actual Perl scalar
  sub _load_scalar {
      my ($self, $string, $indent, $lines) = @_;
  
      # Trim trailing whitespace
      $string =~ s/\s*\z//;
  
      # Explitic null/undef
      return undef if $string eq '~';
  
      # Single quote
      if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
          return $self->_unquote_single($1);
      }
  
      # Double quote.
      if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
          return $self->_unquote_double($1);
      }
  
      # Special cases
      if ( $string =~ /^[\'\"!&]/ ) {
          die \"CPAN::Meta::YAML does not support a feature in line '$string'";
      }
      return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
      return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
  
      # Regular unquoted string
      if ( $string !~ /^[>|]/ ) {
          die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
              if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
                  $string =~ /:(?:\s|$)/;
          $string =~ s/\s+#.*\z//;
          return $string;
      }
  
      # Error
      die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
  
      # Check the indent depth
      $lines->[0]   =~ /^(\s*)/;
      $indent->[-1] = length("$1");
      if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
          die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
      }
  
      # Pull the lines
      my @multiline = ();
      while ( @$lines ) {
          $lines->[0] =~ /^(\s*)/;
          last unless length($1) >= $indent->[-1];
          push @multiline, substr(shift(@$lines), length($1));
      }
  
      my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
      my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
      return join( $j, @multiline ) . $t;
  }
  
  # Load an array
  sub _load_array {
      my ($self, $array, $indent, $lines) = @_;
  
      while ( @$lines ) {
          # Check for a new document
          if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
              while ( @$lines and $lines->[0] !~ /^---/ ) {
                  shift @$lines;
              }
              return 1;
          }
  
          # Check the indent level
          $lines->[0] =~ /^(\s*)/;
          if ( length($1) < $indent->[-1] ) {
              return 1;
          } elsif ( length($1) > $indent->[-1] ) {
              die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
          }
  
          if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
              # Inline nested hash
              my $indent2 = length("$1");
              $lines->[0] =~ s/-/ /;
              push @$array, { };
              $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
  
          } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
              shift @$lines;
              unless ( @$lines ) {
                  push @$array, undef;
                  return 1;
              }
              if ( $lines->[0] =~ /^(\s*)\-/ ) {
                  my $indent2 = length("$1");
                  if ( $indent->[-1] == $indent2 ) {
                      # Null array entry
                      push @$array, undef;
                  } else {
                      # Naked indenter
                      push @$array, [ ];
                      $self->_load_array(
                          $array->[-1], [ @$indent, $indent2 ], $lines
                      );
                  }
  
              } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
                  push @$array, { };
                  $self->_load_hash(
                      $array->[-1], [ @$indent, length("$1") ], $lines
                  );
  
              } else {
                  die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
              }
  
          } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
              # Array entry with a value
              shift @$lines;
              push @$array, $self->_load_scalar(
                  "$2", [ @$indent, undef ], $lines
              );
  
          } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
              # This is probably a structure like the following...
              # ---
              # foo:
              # - list
              # bar: value
              #
              # ... so lets return and let the hash parser handle it
              return 1;
  
          } else {
              die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
          }
      }
  
      return 1;
  }
  
  # Load a hash
  sub _load_hash {
      my ($self, $hash, $indent, $lines) = @_;
  
      while ( @$lines ) {
          # Check for a new document
          if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
              while ( @$lines and $lines->[0] !~ /^---/ ) {
                  shift @$lines;
              }
              return 1;
          }
  
          # Check the indent level
          $lines->[0] =~ /^(\s*)/;
          if ( length($1) < $indent->[-1] ) {
              return 1;
          } elsif ( length($1) > $indent->[-1] ) {
              die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
          }
  
          # Find the key
          my $key;
  
          # Quoted keys
          if ( $lines->[0] =~
              s/^\s*$re_capture_single_quoted$re_key_value_separator//
          ) {
              $key = $self->_unquote_single($1);
          }
          elsif ( $lines->[0] =~
              s/^\s*$re_capture_double_quoted$re_key_value_separator//
          ) {
              $key = $self->_unquote_double($1);
          }
          elsif ( $lines->[0] =~
              s/^\s*$re_capture_unquoted_key$re_key_value_separator//
          ) {
              $key = $1;
              $key =~ s/\s+$//;
          }
          elsif ( $lines->[0] =~ /^\s*\?/ ) {
              die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
          }
          else {
              die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
          }
  
          if ( exists $hash->{$key} ) {
              warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
          }
  
          # Do we have a value?
          if ( length $lines->[0] ) {
              # Yes
              $hash->{$key} = $self->_load_scalar(
                  shift(@$lines), [ @$indent, undef ], $lines
              );
          } else {
              # An indent
              shift @$lines;
              unless ( @$lines ) {
                  $hash->{$key} = undef;
                  return 1;
              }
              if ( $lines->[0] =~ /^(\s*)-/ ) {
                  $hash->{$key} = [];
                  $self->_load_array(
                      $hash->{$key}, [ @$indent, length($1) ], $lines
                  );
              } elsif ( $lines->[0] =~ /^(\s*)./ ) {
                  my $indent2 = length("$1");
                  if ( $indent->[-1] >= $indent2 ) {
                      # Null hash entry
                      $hash->{$key} = undef;
                  } else {
                      $hash->{$key} = {};
                      $self->_load_hash(
                          $hash->{$key}, [ @$indent, length($1) ], $lines
                      );
                  }
              }
          }
      }
  
      return 1;
  }
  
  
  ###
  # Dumper functions:
  
  # Save an object to a file
  sub _dump_file {
      my $self = shift;
  
      require Fcntl;
  
      # Check the file
      my $file = shift or $self->_error( 'You did not specify a file name' );
  
      my $fh;
      # flock if available (or warn if not possible for OS-specific reasons)
      if ( _can_flock() ) {
          # Open without truncation (truncate comes after lock)
          my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
          sysopen( $fh, $file, $flags );
          unless ( $fh ) {
              $self->_error("Failed to open file '$file' for writing: $!");
          }
  
          # Use no translation and strict UTF-8
          binmode( $fh, ":raw:encoding(UTF-8)");
  
          flock( $fh, Fcntl::LOCK_EX() )
              or warn "Couldn't lock '$file' for reading: $!";
  
          # truncate and spew contents
          truncate $fh, 0;
          seek $fh, 0, 0;
      }
      else {
          open $fh, ">:unix:encoding(UTF-8)", $file;
      }
  
      # serialize and spew to the handle
      print {$fh} $self->_dump_string;
  
      # close the file (release the lock)
      unless ( close $fh ) {
          $self->_error("Failed to close file '$file': $!");
      }
  
      return 1;
  }
  
  # Save an object to a string
  sub _dump_string {
      my $self = shift;
      return '' unless ref $self && @$self;
  
      # Iterate over the documents
      my $indent = 0;
      my @lines  = ();
  
      eval {
          foreach my $cursor ( @$self ) {
              push @lines, '---';
  
              # An empty document
              if ( ! defined $cursor ) {
                  # Do nothing
  
              # A scalar document
              } elsif ( ! ref $cursor ) {
                  $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
  
              # A list at the root
              } elsif ( ref $cursor eq 'ARRAY' ) {
                  unless ( @$cursor ) {
                      $lines[-1] .= ' []';
                      next;
                  }
                  push @lines, $self->_dump_array( $cursor, $indent, {} );
  
              # A hash at the root
              } elsif ( ref $cursor eq 'HASH' ) {
                  unless ( %$cursor ) {
                      $lines[-1] .= ' {}';
                      next;
                  }
                  push @lines, $self->_dump_hash( $cursor, $indent, {} );
  
              } else {
                  die \("Cannot serialize " . ref($cursor));
              }
          }
      };
      if ( ref $@ eq 'SCALAR' ) {
          $self->_error(${$@});
      } elsif ( $@ ) {
          $self->_error($@);
      }
  
      join '', map { "$_\n" } @lines;
  }
  
  sub _has_internal_string_value {
      my $value = shift;
      my $b_obj = B::svref_2object(\$value);  # for round trip problem
      return $b_obj->FLAGS & B::SVf_POK();
  }
  
  sub _dump_scalar {
      my $string = $_[1];
      my $is_key = $_[2];
      # Check this before checking length or it winds up looking like a string!
      my $has_string_flag = _has_internal_string_value($string);
      return '~'  unless defined $string;
      return "''" unless length  $string;
      if (Scalar::Util::looks_like_number($string)) {
          # keys and values that have been used as strings get quoted
          if ( $is_key || $has_string_flag ) {
              return qq['$string'];
          }
          else {
              return $string;
          }
      }
      if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
          $string =~ s/\\/\\\\/g;
          $string =~ s/"/\\"/g;
          $string =~ s/\n/\\n/g;
          $string =~ s/[\x85]/\\N/g;
          $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
          $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
          return qq|"$string"|;
      }
      if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
          $QUOTE{$string}
      ) {
          return "'$string'";
      }
      return $string;
  }
  
  sub _dump_array {
      my ($self, $array, $indent, $seen) = @_;
      if ( $seen->{refaddr($array)}++ ) {
          die \"CPAN::Meta::YAML does not support circular references";
      }
      my @lines  = ();
      foreach my $el ( @$array ) {
          my $line = ('  ' x $indent) . '-';
          my $type = ref $el;
          if ( ! $type ) {
              $line .= ' ' . $self->_dump_scalar( $el );
              push @lines, $line;
  
          } elsif ( $type eq 'ARRAY' ) {
              if ( @$el ) {
                  push @lines, $line;
                  push @lines, $self->_dump_array( $el, $indent + 1, $seen );
              } else {
                  $line .= ' []';
                  push @lines, $line;
              }
  
          } elsif ( $type eq 'HASH' ) {
              if ( keys %$el ) {
                  push @lines, $line;
                  push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
              } else {
                  $line .= ' {}';
                  push @lines, $line;
              }
  
          } else {
              die \"CPAN::Meta::YAML does not support $type references";
          }
      }
  
      @lines;
  }
  
  sub _dump_hash {
      my ($self, $hash, $indent, $seen) = @_;
      if ( $seen->{refaddr($hash)}++ ) {
          die \"CPAN::Meta::YAML does not support circular references";
      }
      my @lines  = ();
      foreach my $name ( sort keys %$hash ) {
          my $el   = $hash->{$name};
          my $line = ('  ' x $indent) . $self->_dump_scalar($name, 1) . ":";
          my $type = ref $el;
          if ( ! $type ) {
              $line .= ' ' . $self->_dump_scalar( $el );
              push @lines, $line;
  
          } elsif ( $type eq 'ARRAY' ) {
              if ( @$el ) {
                  push @lines, $line;
                  push @lines, $self->_dump_array( $el, $indent + 1, $seen );
              } else {
                  $line .= ' []';
                  push @lines, $line;
              }
  
          } elsif ( $type eq 'HASH' ) {
              if ( keys %$el ) {
                  push @lines, $line;
                  push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
              } else {
                  $line .= ' {}';
                  push @lines, $line;
              }
  
          } else {
              die \"CPAN::Meta::YAML does not support $type references";
          }
      }
  
      @lines;
  }
  
  
  
  #####################################################################
  # DEPRECATED API methods:
  
  # Error storage (DEPRECATED as of 1.57)
  our $errstr    = '';
  
  # Set error
  sub _error {
      require Carp;
      $errstr = $_[1];
      $errstr =~ s/ at \S+ line \d+.*//;
      Carp::croak( $errstr );
  }
  
  # Retrieve error
  my $errstr_warned;
  sub errstr {
      require Carp;
      Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
          unless $errstr_warned++;
      $errstr;
  }
  
  
  
  
  #####################################################################
  # Helper functions. Possibly not needed.
  
  
  # Use to detect nv or iv
  use B;
  
  # XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
  # Some platforms can't flock :-(
  # XXX-XDG I think it is.  When reading and writing files, we ought
  # to be locking whenever possible.  People (foolishly) use YAML
  # files for things like session storage, which has race issues.
  my $HAS_FLOCK;
  sub _can_flock {
      if ( defined $HAS_FLOCK ) {
          return $HAS_FLOCK;
      }
      else {
          require Config;
          my $c = \%Config::Config;
          $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
          require Fcntl if $HAS_FLOCK;
          return $HAS_FLOCK;
      }
  }
  
  
  # XXX-INGY Is this core in 5.8.1? Can we remove this?
  # XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
  #####################################################################
  # Use Scalar::Util if possible, otherwise emulate it
  
  use Scalar::Util ();
  BEGIN {
      local $@;
      if ( eval { Scalar::Util->VERSION(1.18); } ) {
          *refaddr = *Scalar::Util::refaddr;
      }
      else {
          eval <<'END_PERL';
  # Scalar::Util failed to load or too old
  sub refaddr {
      my $pkg = ref($_[0]) or return undef;
      if ( !! UNIVERSAL::can($_[0], 'can') ) {
          bless $_[0], 'Scalar::Util::Fake';
      } else {
          $pkg = undef;
      }
      "$_[0]" =~ /0x(\w+)/;
      my $i = do { no warnings 'portable'; hex $1 };
      bless $_[0], $pkg if defined $pkg;
      $i;
  }
  END_PERL
      }
  }
  
  delete $CPAN::Meta::YAML::{refaddr};
  
  1;
  
  # XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
  # but leaving grey area stuff up here.
  #
  # I would like to change Read/Write to Load/Dump below without
  # changing the actual API names.
  #
  # It might be better to put Load/Dump API in the SYNOPSIS instead of the
  # dubious OO API.
  #
  # null and bool explanations may be outdated.
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
  
  =head1 VERSION
  
  version 0.018
  
  =head1 SYNOPSIS
  
      use CPAN::Meta::YAML;
  
      # reading a META file
      open $fh, "<:utf8", "META.yml";
      $yaml_text = do { local $/; <$fh> };
      $yaml = CPAN::Meta::YAML->read_string($yaml_text)
        or die CPAN::Meta::YAML->errstr;
  
      # finding the metadata
      $meta = $yaml->[0];
  
      # writing a META file
      $yaml_text = $yaml->write_string
        or die CPAN::Meta::YAML->errstr;
      open $fh, ">:utf8", "META.yml";
      print $fh $yaml_text;
  
  =head1 DESCRIPTION
  
  This module implements a subset of the YAML specification for use in reading
  and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>.  It should
  not be used for any other general YAML parsing or generation task.
  
  NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded.  Users are
  responsible for proper encoding and decoding.  In particular, the C<read> and
  C<write> methods do B<not> support UTF-8 and should not be used.
  
  =head1 SUPPORT
  
  This module is currently derived from L<YAML::Tiny> by Adam Kennedy.  If
  there are bugs in how it parses a particular META.yml file, please file
  a bug report in the YAML::Tiny bugtracker:
  L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
  
  =head1 SEE ALSO
  
  L<YAML::Tiny>, L<YAML>, L<YAML::XS>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by Adam Kennedy.
  
  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
  
  __END__
  
  
  # ABSTRACT: Read and write a subset of YAML for CPAN Meta files
  
  
CPAN_META_YAML

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

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

$fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_TINY';
  use 5.006;
  use strict;
  no strict 'refs';
  use warnings;
  
  package Class::Tiny;
  # ABSTRACT: Minimalist class construction
  
  our $VERSION = '1.006';
  
  use Carp ();
  
  # load as .pm to hide from min version scanners
  require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic:
  
  my %CLASS_ATTRIBUTES;
  
  sub import {
      my $class = shift;
      my $pkg   = caller;
      $class->prepare_class($pkg);
      $class->create_attributes( $pkg, @_ ) if @_;
  }
  
  sub prepare_class {
      my ( $class, $pkg ) = @_;
      @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"};
  }
  
  # adapted from Object::Tiny and Object::Tiny::RW
  sub create_attributes {
      my ( $class, $pkg, @spec ) = @_;
      my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec;
      my @attr = grep {
          defined and !ref and /^[^\W\d]\w*$/s
            or Carp::croak "Invalid accessor name '$_'"
      } keys %defaults;
      $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
      $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
      Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
  }
  
  sub _gen_accessor {
      my ( $class, $pkg, $name ) = @_;
      my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name};
  
      my $sub =
        $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) );
  
      # default = outer_default avoids "won't stay shared" bug
      eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic
      Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
  }
  
  # NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and
  # could break if the internals of Class::Tiny need to change for any
  # reason.  That said, I currently see no reason why this would be likely to
  # change.
  #
  # The generated sub body should assume that a '$default' variable will be
  # in scope (i.e. when the sub is evaluated) with any default value/coderef
  sub __gen_sub_body {
      my ( $self, $name, $has_default, $default_type ) = @_;
  
      if ( $has_default && $default_type eq 'CODE' ) {
          return << "HERE";
  sub $name {
      return (
            ( \@_ == 1 && exists \$_[0]{$name} )
          ? ( \$_[0]{$name} )
          : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) )
      );
  }
  HERE
      }
      elsif ($has_default) {
          return << "HERE";
  sub $name {
      return (
            ( \@_ == 1 && exists \$_[0]{$name} )
          ? ( \$_[0]{$name} )
          : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default )
      );
  }
  HERE
      }
      else {
          return << "HERE";
  sub $name {
      return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} =  \$_[1] );
  }
  HERE
      }
  }
  
  sub get_all_attributes_for {
      my ( $class, $pkg ) = @_;
      my %attr =
        map { $_ => undef }
        map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) };
      return keys %attr;
  }
  
  sub get_all_attribute_defaults_for {
      my ( $class, $pkg ) = @_;
      my $defaults = {};
      for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) {
          while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) {
              $defaults->{$k} = $v;
          }
      }
      return $defaults;
  }
  
  package Class::Tiny::Object;
  # ABSTRACT: Base class for classes built with Class::Tiny
  
  our $VERSION = '1.006';
  
  my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );
  
  my $_PRECACHE = sub {
      no warnings 'once'; # needed to avoid downstream warnings
      my ($class) = @_;
      my $linear_isa =
        @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
        ? [$class]
        : mro::get_linear_isa($class);
      $DEMOLISH_CACHE{$class} = [
          map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
          map { "$_\::DEMOLISH" } @$linear_isa
      ];
      $BUILD_CACHE{$class} = [
          map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
          map { "$_\::BUILD" } reverse @$linear_isa
      ];
      $HAS_BUILDARGS{$class} = $class->can("BUILDARGS");
      return $ATTR_CACHE{$class} =
        { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) };
  };
  
  sub new {
      my $class = shift;
      my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class);
  
      # handle hash ref or key/value arguments
      my $args;
      if ( $HAS_BUILDARGS{$class} ) {
          $args = $class->BUILDARGS(@_);
      }
      else {
          if ( @_ == 1 && ref $_[0] ) {
              my %copy = eval { %{ $_[0] } }; # try shallow copy
              Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@;
              $args = \%copy;
          }
          elsif ( @_ % 2 == 0 ) {
              $args = {@_};
          }
          else {
              Carp::croak("$class->new() got an odd number of elements");
          }
      }
  
      # create object and invoke BUILD (unless we were given __no_BUILD__)
      my $self =
        bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args },
        $class;
      $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} };
  
      return $self;
  }
  
  sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } }
  
  # Adapted from Moo and its dependencies
  require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE};
  
  sub DESTROY {
      my $self  = shift;
      my $class = ref $self;
      my $in_global_destruction =
        defined ${^GLOBAL_PHASE}
        ? ${^GLOBAL_PHASE} eq 'DESTRUCT'
        : Devel::GlobalDestruction::in_global_destruction();
      for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) {
          my $e = do {
              local ( $?, $@ );
              eval { $demolisher->( $self, $in_global_destruction ) };
              $@;
          };
          no warnings 'misc'; # avoid (in cleanup) warnings
          die $e if $e;       # rethrow
      }
  }
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Class::Tiny - Minimalist class construction
  
  =head1 VERSION
  
  version 1.006
  
  =head1 SYNOPSIS
  
  In F<Person.pm>:
  
    package Person;
  
    use Class::Tiny qw( name );
  
    1;
  
  In F<Employee.pm>:
  
    package Employee;
    use parent 'Person';
  
    use Class::Tiny qw( ssn ), {
      timestamp => sub { time }   # attribute with default
    };
  
    1;
  
  In F<example.pl>:
  
    use Employee;
  
    my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" );
  
    # unknown attributes are ignored
    my $obj = Employee->new( name => "Larry", OS => "Linux" );
    # $obj->{OS} does not exist
  
  =head1 DESCRIPTION
  
  This module offers a minimalist class construction kit in around 120 lines of
  code.  Here is a list of features:
  
  =over 4
  
  =item *
  
  defines attributes via import arguments
  
  =item *
  
  generates read-write accessors
  
  =item *
  
  supports lazy attribute defaults
  
  =item *
  
  supports custom accessors
  
  =item *
  
  superclass provides a standard C<new> constructor
  
  =item *
  
  C<new> takes a hash reference or list of key/value pairs
  
  =item *
  
  C<new> supports providing C<BUILDARGS> to customize constructor options
  
  =item *
  
  C<new> calls C<BUILD> for each class from parent to child
  
  =item *
  
  superclass provides a C<DESTROY> method
  
  =item *
  
  C<DESTROY> calls C<DEMOLISH> for each class from child to parent
  
  =back
  
  Multiple-inheritance is possible, with superclass order determined via
  L<mro::get_linear_isa|mro/Functions>.
  
  It uses no non-core modules for any recent Perl. On Perls older than v5.10 it
  requires L<MRO::Compat>. On Perls older than v5.14, it requires
  L<Devel::GlobalDestruction>.
  
  =head1 USAGE
  
  =head2 Defining attributes
  
  Define attributes as a list of import arguments:
  
      package Foo::Bar;
  
      use Class::Tiny qw(
          name
          id
          height
          weight
      );
  
  For each attribute, a read-write accessor is created unless a subroutine of that
  name already exists:
  
      $obj->name;               # getter
      $obj->name( "John Doe" ); # setter
  
  Attribute names must be valid subroutine identifiers or an exception will
  be thrown.
  
  You can specify lazy defaults by defining attributes with a hash reference.
  Keys define attribute names and values are constants or code references that
  will be evaluated when the attribute is first accessed if no value has been
  set.  The object is passed as an argument to a code reference.
  
      package Foo::WithDefaults;
  
      use Class::Tiny qw/name id/, {
          title     => 'Peon',
          skills    => sub { [] },
          hire_date => sub { $_[0]->_build_hire_date },
      };
  
  When subclassing, if multiple accessors of the same name exist in different
  classes, any default (or lack of default) is determined by standard
  method resolution order.
  
  To make your own custom accessors, just pre-declare the method name before
  loading Class::Tiny:
  
      package Foo::Bar;
  
      use subs 'id';
  
      use Class::Tiny qw( name id );
  
      sub id { ... }
  
  Even if you pre-declare a method name, you must include it in the attribute
  list for Class::Tiny to register it as a valid attribute.
  
  If you set a default for a custom accessor, your accessor will need to retrieve
  the default and do something with it:
  
      package Foo::Bar;
  
      use subs 'id';
  
      use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } };
  
      sub id {
          my $self = shift;
          if (@_) {
              return $self->{id} = shift;
          }
          elsif ( exists $self->{id} ) {
              return $self->{id};
          }
          else {
              my $defaults =
                  Class::Tiny->get_all_attribute_defaults_for( ref $self );
              return $self->{id} = $defaults->{id}->();
          }
      }
  
  =head2 Class::Tiny::Object is your base class
  
  If your class B<does not> already inherit from some class, then
  Class::Tiny::Object will be added to your C<@ISA> to provide C<new> and
  C<DESTROY>.
  
  If your class B<does> inherit from something, then no additional inheritance is
  set up.  If the parent subclasses Class::Tiny::Object, then all is well.  If
  not, then you'll get accessors set up but no constructor or destructor. Don't
  do that unless you really have a special need for it.
  
  Define subclasses as normal.  It's best to define them with L<base>, L<parent>
  or L<superclass> before defining attributes with Class::Tiny so the C<@ISA>
  array is already populated at compile-time:
  
      package Foo::Bar::More;
  
      use parent 'Foo::Bar';
  
      use Class::Tiny qw( shoe_size );
  
  =head2 Object construction
  
  If your class inherits from Class::Tiny::Object (as it should if you followed
  the advice above), it provides the C<new> constructor for you.
  
  Objects can be created with attributes given as a hash reference or as a list
  of key/value pairs:
  
      $obj = Foo::Bar->new( name => "David" );
  
      $obj = Foo::Bar->new( { name => "David" } );
  
  If a reference is passed as a single argument, it must be able to be
  dereferenced as a hash or an exception is thrown.
  
  Unknown attributes in the constructor arguments will be ignored.  Prior to
  version 1.000, unknown attributes were an error, but this made it harder for
  people to cleanly subclass Class::Tiny classes so this feature was removed.
  
  You can define a C<BUILDARGS> method to change how arguments to new are
  handled.  It will receive the constructor arguments as they were provided and
  must return a hash reference of key/value pairs (or else throw an
  exception).
  
      sub BUILDARGS {
         my $class = shift;
         my $name = shift || "John Doe";
         return { name => $name };
       };
  
       Foo::Bar->new( "David" );
       Foo::Bar->new(); # "John Doe"
  
  Unknown attributes returned from C<BUILDARGS> will be ignored.
  
  =head2 BUILD
  
  If your class or any superclass defines a C<BUILD> method, it will be called
  by the constructor from the furthest parent class down to the child class after
  the object has been created.
  
  It is passed the constructor arguments as a hash reference.  The return value
  is ignored.  Use C<BUILD> for validation, checking required attributes or
  setting default values that depend on other attributes.
  
      sub BUILD {
          my ($self, $args) = @_;
  
          for my $req ( qw/name age/ ) {
              croak "$req attribute required" unless defined $self->$req;
          }
  
          croak "Age must be non-negative" if $self->age < 0;
  
          $self->msg( "Hello " . $self->name );
      }
  
  The argument reference is a copy, so deleting elements won't affect data in the
  original (but changes will be passed to other BUILD methods in C<@ISA>).
  
  =head2 DEMOLISH
  
  Class::Tiny provides a C<DESTROY> method.  If your class or any superclass
  defines a C<DEMOLISH> method, they will be called from the child class to the
  furthest parent class during object destruction.  It is provided a single
  boolean argument indicating whether Perl is in global destruction.  Return
  values and errors are ignored.
  
      sub DEMOLISH {
          my ($self, $global_destruct) = @_;
          $self->cleanup();
      }
  
  =head2 Introspection and internals
  
  You can retrieve an unsorted list of valid attributes known to Class::Tiny
  for a class and its superclasses with the C<get_all_attributes_for> class
  method.
  
      my @attrs = Class::Tiny->get_all_attributes_for("Employee");
      # returns qw/name ssn timestamp/
  
  Likewise, a hash reference of all valid attributes and default values (or code
  references) may be retrieved with the C<get_all_attribute_defaults_for> class
  method.  Any attributes without a default will be C<undef>.
  
      my $def = Class::Tiny->get_all_attribute_defaults_for("Employee");
      # returns {
      #   name => undef,
      #   ssn => undef
      #   timestamp => $coderef
      # }
  
  The C<import> method uses two class methods, C<prepare_class> and
  C<create_attributes> to set up the C<@ISA> array and attributes.  Anyone
  attempting to extend Class::Tiny itself should use these instead of mocking up
  a call to C<import>.
  
  When the first object is created, linearized C<@ISA>, the valid attribute list
  and various subroutine references are cached for speed.  Ensure that all
  inheritance and methods are in place before creating objects. (You don't want
  to be changing that once you create objects anyway, right?)
  
  =for Pod::Coverage new get_all_attributes_for get_all_attribute_defaults_for
  prepare_class create_attributes
  
  =head1 RATIONALE
  
  =head2 Why this instead of Object::Tiny or Class::Accessor or something else?
  
  I wanted something so simple that it could potentially be used by core Perl
  modules I help maintain (or hope to write), most of which either use
  L<Class::Struct> or roll-their-own OO framework each time.
  
  L<Object::Tiny> and L<Object::Tiny::RW> were close to what I wanted, but
  lacking some features I deemed necessary, and their maintainers have an even
  more strict philosophy against feature creep than I have.
  
  I also considered L<Class::Accessor>, which has been around a long time and is
  heavily used, but it, too, lacked features I wanted and did things in ways I
  considered poor design.
  
  I looked for something else on CPAN, but after checking a dozen class creators
  I realized I could implement exactly what I wanted faster than I could search
  CPAN for something merely sufficient.
  
  In general, compared to most things on CPAN (other than Object::Tiny),
  Class::Tiny is smaller in implementation and simpler in API.
  
  Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny
  ("O::T") and Class::Accessor ("C::A"):
  
   FEATURE                            C::T    O::T      C::A
   --------------------------------------------------------------
   attributes defined via import      yes     yes       no
   read/write accessors               yes     no        yes
   lazy attribute defaults            yes     no        no
   provides new                       yes     yes       yes
   provides DESTROY                   yes     no        no
   new takes either hashref or list   yes     no (list) no (hash)
   Moo(se)-like BUILD/DEMOLISH        yes     no        no
   Moo(se)-like BUILDARGS             yes     no        no
   no extraneous methods via @ISA     yes     yes       no
  
  =head2 Why this instead of Moose or Moo?
  
  L<Moose> and L<Moo> are both excellent OO frameworks.  Moose offers a powerful
  meta-object protocol (MOP), but is slow to start up and has about 30 non-core
  dependencies including XS modules.  Moo is faster to start up and has about 10
  pure Perl dependencies but provides no true MOP, relying instead on its ability
  to transparently upgrade Moo to Moose when Moose's full feature set is
  required.
  
  By contrast, Class::Tiny has no MOP and has B<zero> non-core dependencies for
  Perls in the L<support window|perlpolicy>.  It has far less code, less
  complexity and no learning curve. If you don't need or can't afford what Moo or
  Moose offer, this is intended to be a reasonable fallback.
  
  That said, Class::Tiny offers Moose-like conventions for things like C<BUILD>
  and C<DEMOLISH> for some minimal interoperability and an easier upgrade path.
  
  =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/Class-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/Class-Tiny>
  
    git clone https://github.com/dagolden/Class-Tiny.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =for stopwords Dagfinn Ilmari Mannsåker David Golden Gelu Lupas Karen Etheridge Olivier Mengué Toby Inkster
  
  =over 4
  
  =item *
  
  Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
  
  =item *
  
  David Golden <xdg@xdg.me>
  
  =item *
  
  Gelu Lupas <gelu@devnull.ro>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Olivier Mengué <dolmen@cpan.org>
  
  =item *
  
  Toby Inkster <tobyink@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
CLASS_TINY

$fatpacked{"Devel/GlobalDestruction.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEVEL_GLOBALDESTRUCTION';
  package Devel::GlobalDestruction;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.14';
  
  use Sub::Exporter::Progressive -setup => {
    exports => [ qw(in_global_destruction) ],
    groups  => { default => [ -all ] },
  };
  
  # we run 5.14+ - everything is in core
  #
  if (defined ${^GLOBAL_PHASE}) {
    eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1'
      or die $@;
  }
  # try to load the xs version if it was compiled
  #
  elsif (eval {
    require Devel::GlobalDestruction::XS;
    no warnings 'once';
    *in_global_destruction = \&Devel::GlobalDestruction::XS::in_global_destruction;
    1;
  }) {
    # the eval already installed everything, nothing to do
  }
  else {
    # internally, PL_main_cv is set to Nullcv immediately before entering
    # global destruction and we can use B to detect that.  B::main_cv will
    # only ever be a B::CV or a B::SPECIAL that is a reference to 0
    require B;
    eval 'sub in_global_destruction () { ${B::main_cv()} == 0 }; 1'
      or die $@;
  }
  
  1;  # keep require happy
  
  
  __END__
  
  =head1 NAME
  
  Devel::GlobalDestruction - Provides function returning the equivalent of
  C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls.
  
  =head1 SYNOPSIS
  
      package Foo;
      use Devel::GlobalDestruction;
  
      use namespace::clean; # to avoid having an "in_global_destruction" method
  
      sub DESTROY {
          return if in_global_destruction;
  
          do_something_a_little_tricky();
      }
  
  =head1 DESCRIPTION
  
  Perl's global destruction is a little tricky to deal with WRT finalizers
  because it's not ordered and objects can sometimes disappear.
  
  Writing defensive destructors is hard and annoying, and usually if global
  destruction is happening you only need the destructors that free up non
  process local resources to actually execute.
  
  For these constructors you can avoid the mess by simply bailing out if global
  destruction is in effect.
  
  =head1 EXPORTS
  
  This module uses L<Sub::Exporter::Progressive> so the exports may be renamed,
  aliased, etc. if L<Sub::Exporter> is present.
  
  =over 4
  
  =item in_global_destruction
  
  Returns true if the interpreter is in global destruction. In perl 5.14+, this
  returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, detects it using
  the value of C<PL_main_cv> or C<PL_dirty>.
  
  =back
  
  =head1 AUTHORS
  
  Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
  
  Florian Ragwitz E<lt>rafl@debian.orgE<gt>
  
  Jesse Luehrs E<lt>doy@tozt.netE<gt>
  
  Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
  
  Arthur Axel 'fREW' Schmidt E<lt>frioux@gmail.comE<gt>
  
  Elizabeth Mattijsen E<lt>liz@dijkmat.nlE<gt>
  
  Greham Knop E<lt>haarg@haarg.orgE<gt>
  
  =head1 COPYRIGHT
  
      Copyright (c) 2008 Yuval Kogman. All rights reserved
      This program is free software; you can redistribute
      it and/or modify it under the same terms as Perl itself.
  
  =cut
DEVEL_GLOBALDESTRUCTION

$fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER';
  package Exporter;
  
  require 5.006;
  
  # Be lean.
  #use strict;
  #no strict 'refs';
  
  our $Debug = 0;
  our $ExportLevel = 0;
  our $Verbose ||= 0;
  our $VERSION = '5.72';
  our (%Cache);
  
  sub as_heavy {
    require Exporter::Heavy;
    # Unfortunately, this does not work if the caller is aliased as *name = \&foo
    # Thus the need to create a lot of identical subroutines
    my $c = (caller(1))[3];
    $c =~ s/.*:://;
    \&{"Exporter::Heavy::heavy_$c"};
  }
  
  sub export {
    goto &{as_heavy()};
  }
  
  sub import {
    my $pkg = shift;
    my $callpkg = caller($ExportLevel);
  
    if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
      *{$callpkg."::import"} = \&import;
      return;
    }
  
    # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
    my $exports = \@{"$pkg\::EXPORT"};
    # But, avoid creating things if they don't exist, which saves a couple of
    # hundred bytes per package processed.
    my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
    return export $pkg, $callpkg, @_
      if $Verbose or $Debug or $fail && @$fail > 1;
    my $export_cache = ($Cache{$pkg} ||= {});
    my $args = @_ or @_ = @$exports;
  
    if ($args and not %$export_cache) {
      s/^&//, $export_cache->{$_} = 1
        foreach (@$exports, @{"$pkg\::EXPORT_OK"});
    }
    my $heavy;
    # Try very hard not to use {} and hence have to  enter scope on the foreach
    # We bomb out of the loop with last as soon as heavy is set.
    if ($args or $fail) {
      ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
                 or $fail and @$fail and $_ eq $fail->[0])) and last
                   foreach (@_);
    } else {
      ($heavy = /\W/) and last
        foreach (@_);
    }
    return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
    local $SIG{__WARN__} = 
  	sub {require Carp; &Carp::carp} if not $SIG{__WARN__};
    # shortcut for the common case of no type character
    *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
  }
  
  # Default methods
  
  sub export_fail {
      my $self = shift;
      @_;
  }
  
  # Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
  # *name = \&foo.  Thus the need to create a lot of identical subroutines
  # Otherwise we could have aliased them to export().
  
  sub export_to_level {
    goto &{as_heavy()};
  }
  
  sub export_tags {
    goto &{as_heavy()};
  }
  
  sub export_ok_tags {
    goto &{as_heavy()};
  }
  
  sub require_version {
    goto &{as_heavy()};
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Exporter - Implements default import method for modules
  
  =head1 SYNOPSIS
  
  In module F<YourModule.pm>:
  
    package YourModule;
    require Exporter;
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(munge frobnicate);  # symbols to export on request
  
  or
  
    package YourModule;
    use Exporter 'import'; # gives you Exporter's import() method directly
    @EXPORT_OK = qw(munge frobnicate);  # symbols to export on request
  
  In other files which wish to use C<YourModule>:
  
    use YourModule qw(frobnicate);      # import listed symbols
    frobnicate ($left, $right)          # calls YourModule::frobnicate
  
  Take a look at L</Good Practices> for some variants
  you will like to use in modern Perl code.
  
  =head1 DESCRIPTION
  
  The Exporter module implements an C<import> method which allows a module
  to export functions and variables to its users' namespaces.  Many modules
  use Exporter rather than implementing their own C<import> method because
  Exporter provides a highly flexible interface, with an implementation optimised
  for the common case.
  
  Perl automatically calls the C<import> method when processing a
  C<use> statement for a module.  Modules and C<use> are documented
  in L<perlfunc> and L<perlmod>.  Understanding the concept of
  modules and how the C<use> statement operates is important to
  understanding the Exporter.
  
  =head2 How to Export
  
  The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
  symbols that are going to be exported into the users name space by
  default, or which they can request to be exported, respectively.  The
  symbols can represent functions, scalars, arrays, hashes, or typeglobs.
  The symbols must be given by full name with the exception that the
  ampersand in front of a function is optional, e.g.
  
      @EXPORT    = qw(afunc $scalar @array);   # afunc is a function
      @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
  
  If you are only exporting function names it is recommended to omit the
  ampersand, as the implementation is faster this way.
  
  =head2 Selecting What to Export
  
  Do B<not> export method names!
  
  Do B<not> export anything else by default without a good reason!
  
  Exports pollute the namespace of the module user.  If you must export
  try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
  common symbol names to reduce the risk of name clashes.
  
  Generally anything not exported is still accessible from outside the
  module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
  syntax.  By convention you can use a leading underscore on names to
  informally indicate that they are 'internal' and not for public use.
  
  (It is actually possible to get private functions by saying:
  
    my $subref = sub { ... };
    $subref->(@args);            # Call it as a function
    $obj->$subref(@args);        # Use it as a method
  
  However if you use them for methods it is up to you to figure out
  how to make inheritance work.)
  
  As a general rule, if the module is trying to be object oriented
  then export nothing.  If it's just a collection of functions then
  C<@EXPORT_OK> anything but use C<@EXPORT> with caution.  For function and
  method names use barewords in preference to names prefixed with
  ampersands for the export lists.
  
  Other module design guidelines can be found in L<perlmod>.
  
  =head2 How to Import
  
  In other files which wish to use your module there are three basic ways for
  them to load your module and import its symbols:
  
  =over 4
  
  =item C<use YourModule;>
  
  This imports all the symbols from YourModule's C<@EXPORT> into the namespace
  of the C<use> statement.
  
  =item C<use YourModule ();>
  
  This causes perl to load your module but does not import any symbols.
  
  =item C<use YourModule qw(...);>
  
  This imports only the symbols listed by the caller into their namespace.
  All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
  occurs.  The advanced export features of Exporter are accessed like this,
  but with list entries that are syntactically distinct from symbol names.
  
  =back
  
  Unless you want to use its advanced features, this is probably all you
  need to know to use Exporter.
  
  =head1 Advanced Features
  
  =head2 Specialised Import Lists
  
  If any of the entries in an import list begins with !, : or / then
  the list is treated as a series of specifications which either add to
  or delete from the list of names to import.  They are processed left to
  right. Specifications are in the form:
  
      [!]name         This name only
      [!]:DEFAULT     All names in @EXPORT
      [!]:tag         All names in $EXPORT_TAGS{tag} anonymous array
      [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match
  
  A leading ! indicates that matching names should be deleted from the
  list of names to import.  If the first specification is a deletion it
  is treated as though preceded by :DEFAULT.  If you just want to import
  extra names in addition to the default set you will still need to
  include :DEFAULT explicitly.
  
  e.g., F<Module.pm> defines:
  
      @EXPORT      = qw(A1 A2 A3 A4 A5);
      @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
      %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
  
  Note that you cannot use tags in @EXPORT or @EXPORT_OK.
  
  Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
  
  An application using Module can say something like:
  
      use Module qw(:DEFAULT :T2 !B3 A3);
  
  Other examples include:
  
      use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
      use POSIX  qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
  
  Remember that most patterns (using //) will need to be anchored
  with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
  
  You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
  specifications are being processed and what is actually being imported
  into modules.
  
  =head2 Exporting Without Using Exporter's import Method
  
  Exporter has a special method, 'export_to_level' which is used in situations
  where you can't directly call Exporter's
  import method.  The export_to_level
  method looks like:
  
      MyPackage->export_to_level(
  	$where_to_export, $package, @what_to_export
      );
  
  where C<$where_to_export> is an integer telling how far up the calling stack
  to export your symbols, and C<@what_to_export> is an array telling what
  symbols *to* export (usually this is C<@_>).  The C<$package> argument is
  currently unused.
  
  For example, suppose that you have a module, A, which already has an
  import function:
  
      package A;
  
      @ISA = qw(Exporter);
      @EXPORT_OK = qw($b);
  
      sub import
      {
  	$A::b = 1;     # not a very useful import method
      }
  
  and you want to Export symbol C<$A::b> back to the module that called 
  package A.  Since Exporter relies on the import method to work, via 
  inheritance, as it stands Exporter::import() will never get called. 
  Instead, say the following:
  
      package A;
      @ISA = qw(Exporter);
      @EXPORT_OK = qw($b);
  
      sub import
      {
  	$A::b = 1;
  	A->export_to_level(1, @_);
      }
  
  This will export the symbols one level 'above' the current package - ie: to 
  the program or module that used package A. 
  
  Note: Be careful not to modify C<@_> at all before you call export_to_level
  - or people using your package will get very unexplained results!
  
  =head2 Exporting Without Inheriting from Exporter
  
  By including Exporter in your C<@ISA> you inherit an Exporter's import() method
  but you also inherit several other helper methods which you probably don't
  want.  To avoid this you can do:
  
    package YourModule;
    use Exporter qw(import);
  
  which will export Exporter's own import() method into YourModule.
  Everything will work as before but you won't need to include Exporter in
  C<@YourModule::ISA>.
  
  Note: This feature was introduced in version 5.57
  of Exporter, released with perl 5.8.3.
  
  =head2 Module Version Checking
  
  The Exporter module will convert an attempt to import a number from a
  module into a call to C<< $module_name->VERSION($value) >>.  This can
  be used to validate that the version of the module being used is
  greater than or equal to the required version.
  
  For historical reasons, Exporter supplies a C<require_version> method that
  simply delegates to C<VERSION>.  Originally, before C<UNIVERSAL::VERSION>
  existed, Exporter would call C<require_version>.
  
  Since the C<UNIVERSAL::VERSION> method treats the C<$VERSION> number as
  a simple numeric value it will regard version 1.10 as lower than
  1.9.  For this reason it is strongly recommended that you use numbers
  with at least two decimal places, e.g., 1.09.
  
  =head2 Managing Unknown Symbols
  
  In some situations you may want to prevent certain symbols from being
  exported.  Typically this applies to extensions which have functions
  or constants that may not exist on some systems.
  
  The names of any symbols that cannot be exported should be listed
  in the C<@EXPORT_FAIL> array.
  
  If a module attempts to import any of these symbols the Exporter
  will give the module an opportunity to handle the situation before
  generating an error.  The Exporter will call an export_fail method
  with a list of the failed symbols:
  
    @failed_symbols = $module_name->export_fail(@failed_symbols);
  
  If the C<export_fail> method returns an empty list then no error is
  recorded and all the requested symbols are exported.  If the returned
  list is not empty then an error is generated for each symbol and the
  export fails.  The Exporter provides a default C<export_fail> method which
  simply returns the list unchanged.
  
  Uses for the C<export_fail> method include giving better error messages
  for some symbols and performing lazy architectural checks (put more
  symbols into C<@EXPORT_FAIL> by default and then take them out if someone
  actually tries to use them and an expensive check shows that they are
  usable on that platform).
  
  =head2 Tag Handling Utility Functions
  
  Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
  C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
  you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
  
    %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
  
    Exporter::export_tags('foo');     # add aa, bb and cc to @EXPORT
    Exporter::export_ok_tags('bar');  # add aa, cc and dd to @EXPORT_OK
  
  Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
  unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
  names being silently added to C<@EXPORT> or C<@EXPORT_OK>.  Future versions
  may make this a fatal error.
  
  =head2 Generating Combined Tags
  
  If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
  useful to create the utility ":all" to simplify "use" statements.
  
  The simplest way to do this is:
  
    %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
  
    # add all the other ":class" tags to the ":all" class,
    # deleting duplicates
    {
      my %seen;
  
      push @{$EXPORT_TAGS{all}},
        grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
    }
  
  F<CGI.pm> creates an ":all" tag which contains some (but not really
  all) of its categories.  That could be done with one small
  change:
  
    # add some of the other ":class" tags to the ":all" class,
    # deleting duplicates
    {
      my %seen;
  
      push @{$EXPORT_TAGS{all}},
        grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
          foreach qw/html2 html3 netscape form cgi internal/;
    }
  
  Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
  
  =head2 C<AUTOLOAD>ed Constants
  
  Many modules make use of C<AUTOLOAD>ing for constant subroutines to
  avoid having to compile and waste memory on rarely used values (see
  L<perlsub> for details on constant subroutines).  Calls to such
  constant subroutines are not optimized away at compile time because
  they can't be checked at compile time for constancy.
  
  Even if a prototype is available at compile time, the body of the
  subroutine is not (it hasn't been C<AUTOLOAD>ed yet).  perl needs to
  examine both the C<()> prototype and the body of a subroutine at
  compile time to detect that it can safely replace calls to that
  subroutine with the constant value.
  
  A workaround for this is to call the constants once in a C<BEGIN> block:
  
     package My ;
  
     use Socket ;
  
     foo( SO_LINGER );  ## SO_LINGER NOT optimized away; called at runtime
     BEGIN { SO_LINGER }
     foo( SO_LINGER );  ## SO_LINGER optimized away at compile time.
  
  This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
  SO_LINGER is encountered later in C<My> package.
  
  If you are writing a package that C<AUTOLOAD>s, consider forcing
  an C<AUTOLOAD> for any constants explicitly imported by other packages
  or which are usually used when your package is C<use>d.
  
  =head1 Good Practices
  
  =head2 Declaring C<@EXPORT_OK> and Friends
  
  When using C<Exporter> with the standard C<strict> and C<warnings>
  pragmas, the C<our> keyword is needed to declare the package
  variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
  
    our @ISA = qw(Exporter);
    our @EXPORT_OK = qw(munge frobnicate);
  
  If backward compatibility for Perls under 5.6 is important,
  one must write instead a C<use vars> statement.
  
    use vars qw(@ISA @EXPORT_OK);
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(munge frobnicate);
  
  =head2 Playing Safe
  
  There are some caveats with the use of runtime statements
  like C<require Exporter> and the assignment to package
  variables, which can be very subtle for the unaware programmer.
  This may happen for instance with mutually recursive
  modules, which are affected by the time the relevant
  constructions are executed.
  
  The ideal (but a bit ugly) way to never have to think
  about that is to use C<BEGIN> blocks.  So the first part
  of the L</SYNOPSIS> code could be rewritten as:
  
    package YourModule;
  
    use strict;
    use warnings;
  
    our (@ISA, @EXPORT_OK);
    BEGIN {
       require Exporter;
       @ISA = qw(Exporter);
       @EXPORT_OK = qw(munge frobnicate);  # symbols to export on request
    }
  
  The C<BEGIN> will assure that the loading of F<Exporter.pm>
  and the assignments to C<@ISA> and C<@EXPORT_OK> happen
  immediately, leaving no room for something to get awry
  or just plain wrong.
  
  With respect to loading C<Exporter> and inheriting, there
  are alternatives with the use of modules like C<base> and C<parent>.
  
    use base qw(Exporter);
    # or
    use parent qw(Exporter);
  
  Any of these statements are nice replacements for
  C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
  with the same compile-time effect.  The basic difference
  is that C<base> code interacts with declared C<fields>
  while C<parent> is a streamlined version of the older
  C<base> code to just establish the IS-A relationship.
  
  For more details, see the documentation and code of
  L<base> and L<parent>.
  
  Another thorough remedy to that runtime
  vs. compile-time trap is to use L<Exporter::Easy>,
  which is a wrapper of Exporter that allows all
  boilerplate code at a single gulp in the
  use statement.
  
     use Exporter::Easy (
         OK => [ qw(munge frobnicate) ],
     );
     # @ISA setup is automatic
     # all assignments happen at compile time
  
  =head2 What Not to Export
  
  You have been warned already in L</Selecting What to Export>
  to not export:
  
  =over 4
  
  =item *
  
  method names (because you don't need to
  and that's likely to not do what you want),
  
  =item *
  
  anything by default (because you don't want to surprise your users...
  badly)
  
  =item *
  
  anything you don't need to (because less is more)
  
  =back
  
  There's one more item to add to this list.  Do B<not>
  export variable names.  Just because C<Exporter> lets you
  do that, it does not mean you should.
  
    @EXPORT_OK = qw($svar @avar %hvar); # DON'T!
  
  Exporting variables is not a good idea.  They can
  change under the hood, provoking horrible
  effects at-a-distance that are too hard to track
  and to fix.  Trust me: they are not worth it.
  
  To provide the capability to set/get class-wide
  settings, it is best instead to provide accessors
  as subroutines or class methods instead.
  
  =head1 SEE ALSO
  
  C<Exporter> is definitely not the only module with
  symbol exporter capabilities.  At CPAN, you may find
  a bunch of them.  Some are lighter.  Some
  provide improved APIs and features.  Pick the one
  that fits your needs.  The following is
  a sample list of such modules.
  
      Exporter::Easy
      Exporter::Lite
      Exporter::Renaming
      Exporter::Tidy
      Sub::Exporter / Sub::Installer
      Perl6::Export / Perl6::Export::Attrs
  
  =head1 LICENSE
  
  This library is free software.  You can redistribute it
  and/or modify it under the same terms as Perl itself.
  
  =cut
  
  
  
EXPORTER

$fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY';
  package Exporter::Heavy;
  
  use strict;
  no strict 'refs';
  
  # On one line so MakeMaker will see it.
  require Exporter;  our $VERSION = $Exporter::VERSION;
  
  =head1 NAME
  
  Exporter::Heavy - Exporter guts
  
  =head1 SYNOPSIS
  
  (internal use only)
  
  =head1 DESCRIPTION
  
  No user-serviceable parts inside.
  
  =cut
  
  #
  # We go to a lot of trouble not to 'require Carp' at file scope,
  #  because Carp requires Exporter, and something has to give.
  #
  
  sub _rebuild_cache {
      my ($pkg, $exports, $cache) = @_;
      s/^&// foreach @$exports;
      @{$cache}{@$exports} = (1) x @$exports;
      my $ok = \@{"${pkg}::EXPORT_OK"};
      if (@$ok) {
  	s/^&// foreach @$ok;
  	@{$cache}{@$ok} = (1) x @$ok;
      }
  }
  
  sub heavy_export {
  
      # Save the old __WARN__ handler in case it was defined
      my $oldwarn = $SIG{__WARN__};
  
      # First make import warnings look like they're coming from the "use".
      local $SIG{__WARN__} = sub {
  	# restore it back so proper stacking occurs
  	local $SIG{__WARN__} = $oldwarn;
  	my $text = shift;
  	if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
  	    require Carp;
  	    local $Carp::CarpLevel = 1;	# ignore package calling us too.
  	    Carp::carp($text);
  	}
  	else {
  	    warn $text;
  	}
      };
      local $SIG{__DIE__} = sub {
  	require Carp;
  	local $Carp::CarpLevel = 1;	# ignore package calling us too.
  	Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
  	    if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
      };
  
      my($pkg, $callpkg, @imports) = @_;
      my($type, $sym, $cache_is_current, $oops);
      my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
                                     $Exporter::Cache{$pkg} ||= {});
  
      if (@imports) {
  	if (!%$export_cache) {
  	    _rebuild_cache ($pkg, $exports, $export_cache);
  	    $cache_is_current = 1;
  	}
  
  	if (grep m{^[/!:]}, @imports) {
  	    my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  	    my $tagdata;
  	    my %imports;
  	    my($remove, $spec, @names, @allexports);
  	    # negated first item implies starting with default set:
  	    unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
  	    foreach $spec (@imports){
  		$remove = $spec =~ s/^!//;
  
  		if ($spec =~ s/^://){
  		    if ($spec eq 'DEFAULT'){
  			@names = @$exports;
  		    }
  		    elsif ($tagdata = $tagsref->{$spec}) {
  			@names = @$tagdata;
  		    }
  		    else {
  			warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
  			++$oops;
  			next;
  		    }
  		}
  		elsif ($spec =~ m:^/(.*)/$:){
  		    my $patn = $1;
  		    @allexports = keys %$export_cache unless @allexports; # only do keys once
  		    @names = grep(/$patn/, @allexports); # not anchored by default
  		}
  		else {
  		    @names = ($spec); # is a normal symbol name
  		}
  
  		warn "Import ".($remove ? "del":"add").": @names "
  		    if $Exporter::Verbose;
  
  		if ($remove) {
  		   foreach $sym (@names) { delete $imports{$sym} } 
  		}
  		else {
  		    @imports{@names} = (1) x @names;
  		}
  	    }
  	    @imports = keys %imports;
  	}
  
          my @carp;
  	foreach $sym (@imports) {
  	    if (!$export_cache->{$sym}) {
  		if ($sym =~ m/^\d/) {
  		    $pkg->VERSION($sym); # inherit from UNIVERSAL
  		    # If the version number was the only thing specified
  		    # then we should act as if nothing was specified:
  		    if (@imports == 1) {
  			@imports = @$exports;
  			last;
  		    }
  		    # We need a way to emulate 'use Foo ()' but still
  		    # allow an easy version check: "use Foo 1.23, ''";
  		    if (@imports == 2 and !$imports[1]) {
  			@imports = ();
  			last;
  		    }
  		} elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
  		    # Last chance - see if they've updated EXPORT_OK since we
  		    # cached it.
  
  		    unless ($cache_is_current) {
  			%$export_cache = ();
  			_rebuild_cache ($pkg, $exports, $export_cache);
  			$cache_is_current = 1;
  		    }
  
  		    if (!$export_cache->{$sym}) {
  			# accumulate the non-exports
  			push @carp,
  			  qq["$sym" is not exported by the $pkg module\n];
  			$oops++;
  		    }
  		}
  	    }
  	}
  	if ($oops) {
  	    require Carp;
  	    Carp::croak("@{carp}Can't continue after import errors");
  	}
      }
      else {
  	@imports = @$exports;
      }
  
      my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
                                $Exporter::FailCache{$pkg} ||= {});
  
      if (@$fail) {
  	if (!%$fail_cache) {
  	    # Build cache of symbols. Optimise the lookup by adding
  	    # barewords twice... both with and without a leading &.
  	    # (Technique could be applied to $export_cache at cost of memory)
  	    my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
  	    warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
  	    @{$fail_cache}{@expanded} = (1) x @expanded;
  	}
  	my @failed;
  	foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
  	if (@failed) {
  	    @failed = $pkg->export_fail(@failed);
  	    foreach $sym (@failed) {
                  require Carp;
  		Carp::carp(qq["$sym" is not implemented by the $pkg module ],
  			"on this architecture");
  	    }
  	    if (@failed) {
  		require Carp;
  		Carp::croak("Can't continue after import errors");
  	    }
  	}
      }
  
      warn "Importing into $callpkg from $pkg: ",
  		join(", ",sort @imports) if $Exporter::Verbose;
  
      foreach $sym (@imports) {
  	# shortcut for the common case of no type character
  	(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
  	    unless $sym =~ s/^(\W)//;
  	$type = $1;
  	no warnings 'once';
  	*{"${callpkg}::$sym"} =
  	    $type eq '&' ? \&{"${pkg}::$sym"} :
  	    $type eq '$' ? \${"${pkg}::$sym"} :
  	    $type eq '@' ? \@{"${pkg}::$sym"} :
  	    $type eq '%' ? \%{"${pkg}::$sym"} :
  	    $type eq '*' ?  *{"${pkg}::$sym"} :
  	    do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
      }
  }
  
  sub heavy_export_to_level
  {
        my $pkg = shift;
        my $level = shift;
        (undef) = shift;			# XXX redundant arg
        my $callpkg = caller($level);
        $pkg->export($callpkg, @_);
  }
  
  # Utility functions
  
  sub _push_tags {
      my($pkg, $var, $syms) = @_;
      my @nontag = ();
      my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
      push(@{"${pkg}::$var"},
  	map { $export_tags->{$_} ? @{$export_tags->{$_}} 
                                   : scalar(push(@nontag,$_),$_) }
  		(@$syms) ? @$syms : keys %$export_tags);
      if (@nontag and $^W) {
  	# This may change to a die one day
  	require Carp;
  	Carp::carp(join(", ", @nontag)." are not tags of $pkg");
      }
  }
  
  sub heavy_require_version {
      my($self, $wanted) = @_;
      my $pkg = ref $self || $self;
      return ${pkg}->VERSION($wanted);
  }
  
  sub heavy_export_tags {
    _push_tags((caller)[0], "EXPORT",    \@_);
  }
  
  sub heavy_export_ok_tags {
    _push_tags((caller)[0], "EXPORT_OK", \@_);
  }
  
  1;
EXPORTER_HEAVY

$fatpacked{"File/Fetch.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_FETCH';
  package File::Fetch;
  
  use strict;
  use FileHandle;
  use File::Temp;
  use File::Copy;
  use File::Spec;
  use File::Spec::Unix;
  use File::Basename              qw[dirname];
  
  use Cwd                         qw[cwd];
  use Carp                        qw[carp];
  use IPC::Cmd                    qw[can_run run QUOTE];
  use File::Path                  qw[mkpath];
  use File::Temp                  qw[tempdir];
  use Params::Check               qw[check];
  use Module::Load::Conditional   qw[can_load];
  use Locale::Maketext::Simple    Style => 'gettext';
  
  use vars    qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
                  $BLACKLIST $METHOD_FAIL $VERSION $METHODS
                  $FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4
              ];
  
  $VERSION        = '0.56';
  $VERSION        = eval $VERSION;    # avoid warnings with development releases
  $PREFER_BIN     = 0;                # XXX TODO implement
  $FROM_EMAIL     = 'File-Fetch@example.com';
  $USER_AGENT     = "File::Fetch/$VERSION";
  $BLACKLIST      = [qw|ftp|];
  push @$BLACKLIST, qw|lftp| if $^O eq 'dragonfly' || $^O eq 'hpux';
  $METHOD_FAIL    = { };
  $FTP_PASSIVE    = 1;
  $TIMEOUT        = 0;
  $DEBUG          = 0;
  $WARN           = 1;
  $FORCEIPV4      = 0;
  
  ### methods available to fetch the file depending on the scheme
  $METHODS = {
      http    => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ],
      https   => [ qw|lwp wget curl| ],
      ftp     => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ],
      file    => [ qw|lwp lftp file| ],
      rsync   => [ qw|rsync| ],
      git     => [ qw|git| ],
  };
  
  ### silly warnings ###
  local $Params::Check::VERBOSE               = 1;
  local $Params::Check::VERBOSE               = 1;
  local $Module::Load::Conditional::VERBOSE   = 0;
  local $Module::Load::Conditional::VERBOSE   = 0;
  
  ### Fix CVE-2016-1238 ###
  local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
  
  ### see what OS we are on, important for file:// uris ###
  use constant ON_WIN     => ($^O eq 'MSWin32');
  use constant ON_VMS     => ($^O eq 'VMS');
  use constant ON_UNIX    => (!ON_WIN);
  use constant HAS_VOL    => (ON_WIN);
  use constant HAS_SHARE  => (ON_WIN);
  use constant HAS_FETCH  => ( $^O =~ m!^(freebsd|netbsd|dragonfly)$! );
  
  =pod
  
  =head1 NAME
  
  File::Fetch - A generic file fetching mechanism
  
  =head1 SYNOPSIS
  
      use File::Fetch;
  
      ### build a File::Fetch object ###
      my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
  
      ### fetch the uri to cwd() ###
      my $where = $ff->fetch() or die $ff->error;
  
      ### fetch the uri to /tmp ###
      my $where = $ff->fetch( to => '/tmp' );
  
      ### parsed bits from the uri ###
      $ff->uri;
      $ff->scheme;
      $ff->host;
      $ff->path;
      $ff->file;
  
  =head1 DESCRIPTION
  
  File::Fetch is a generic file fetching mechanism.
  
  It allows you to fetch any file pointed to by a C<ftp>, C<http>,
  C<file>, C<git> or C<rsync> uri by a number of different means.
  
  See the C<HOW IT WORKS> section further down for details.
  
  =head1 ACCESSORS
  
  A C<File::Fetch> object has the following accessors
  
  =over 4
  
  =item $ff->uri
  
  The uri you passed to the constructor
  
  =item $ff->scheme
  
  The scheme from the uri (like 'file', 'http', etc)
  
  =item $ff->host
  
  The hostname in the uri.  Will be empty if host was originally
  'localhost' for a 'file://' url.
  
  =item $ff->vol
  
  On operating systems with the concept of a volume the second element
  of a file:// is considered to the be volume specification for the file.
  Thus on Win32 this routine returns the volume, on other operating
  systems this returns nothing.
  
  On Windows this value may be empty if the uri is to a network share, in
  which case the 'share' property will be defined. Additionally, volume
  specifications that use '|' as ':' will be converted on read to use ':'.
  
  On VMS, which has a volume concept, this field will be empty because VMS
  file specifications are converted to absolute UNIX format and the volume
  information is transparently included.
  
  =item $ff->share
  
  On systems with the concept of a network share (currently only Windows) returns
  the sharename from a file://// url.  On other operating systems returns empty.
  
  =item $ff->path
  
  The path from the uri, will be at least a single '/'.
  
  =item $ff->file
  
  The name of the remote file. For the local file name, the
  result of $ff->output_file will be used.
  
  =item $ff->file_default
  
  The name of the default local file, that $ff->output_file falls back to if
  it would otherwise return no filename. For example when fetching a URI like
  http://www.abc.net.au/ the contents retrieved may be from a remote file called
  'index.html'. The default value of this attribute is literally 'file_default'.
  
  =cut
  
  
  ##########################
  ### Object & Accessors ###
  ##########################
  
  {
      ### template for autogenerated accessors ###
      my $Tmpl = {
          scheme          => { default => 'http' },
          host            => { default => 'localhost' },
          path            => { default => '/' },
          file            => { required => 1 },
          uri             => { required => 1 },
          userinfo        => { default => '' },
          vol             => { default => '' }, # windows for file:// uris
          share           => { default => '' }, # windows for file:// uris
          file_default    => { default => 'file_default' },
          tempdir_root    => { required => 1 }, # Should be lazy-set at ->new()
          _error_msg      => { no_override => 1 },
          _error_msg_long => { no_override => 1 },
      };
  
      for my $method ( keys %$Tmpl ) {
          no strict 'refs';
          *$method = sub {
                          my $self = shift;
                          $self->{$method} = $_[0] if @_;
                          return $self->{$method};
                      }
      }
  
      sub _create {
          my $class = shift;
          my %hash  = @_;
  
          my $args = check( $Tmpl, \%hash ) or return;
  
          bless $args, $class;
  
          if( lc($args->scheme) ne 'file' and not $args->host ) {
              return $class->_error(loc(
                  "Hostname required when fetching from '%1'",$args->scheme));
          }
  
          for (qw[path]) {
              unless( $args->$_() ) { # 5.5.x needs the ()
                  return $class->_error(loc("No '%1' specified",$_));
              }
          }
  
          return $args;
      }
  }
  
  =item $ff->output_file
  
  The name of the output file. This is the same as $ff->file,
  but any query parameters are stripped off. For example:
  
      http://example.com/index.html?x=y
  
  would make the output file be C<index.html> rather than
  C<index.html?x=y>.
  
  =back
  
  =cut
  
  sub output_file {
      my $self = shift;
      my $file = $self->file;
  
      $file =~ s/\?.*$//g;
  
      $file ||= $self->file_default;
  
      return $file;
  }
  
  ### XXX do this or just point to URI::Escape?
  # =head2 $esc_uri = $ff->escaped_uri
  #
  # =cut
  #
  # ### most of this is stolen straight from URI::escape
  # {   ### Build a char->hex map
  #     my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
  #
  #     sub escaped_uri {
  #         my $self = shift;
  #         my $uri  = $self->uri;
  #
  #         ### Default unsafe characters.  RFC 2732 ^(uric - reserved)
  #         $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
  #                     $escapes{$1} || $self->_fail_hi($1)/ge;
  #
  #         return $uri;
  #     }
  #
  #     sub _fail_hi {
  #         my $self = shift;
  #         my $char = shift;
  #
  #         $self->_error(loc(
  #             "Can't escape '%1', try using the '%2' module instead",
  #             sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
  #         ));
  #     }
  #
  #     sub output_file {
  #
  #     }
  #
  #
  # }
  
  =head1 METHODS
  
  =head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
  
  Parses the uri and creates a corresponding File::Fetch::Item object,
  that is ready to be C<fetch>ed and returns it.
  
  Returns false on failure.
  
  =cut
  
  sub new {
      my $class = shift;
      my %hash  = @_;
  
      my ($uri, $file_default, $tempdir_root);
      my $tmpl = {
          uri          => { required => 1, store => \$uri },
          file_default => { required => 0, store => \$file_default },
          tempdir_root => { required => 0, store => \$tempdir_root },
      };
  
      check( $tmpl, \%hash ) or return;
  
      ### parse the uri to usable parts ###
      my $href    = $class->_parse_uri( $uri ) or return;
  
      $href->{file_default} = $file_default if $file_default;
      $href->{tempdir_root} = File::Spec->rel2abs( $tempdir_root ) if $tempdir_root;
      $href->{tempdir_root} = File::Spec->rel2abs( Cwd::cwd      ) if not $href->{tempdir_root};
  
      ### make it into a FFI object ###
      my $ff      = $class->_create( %$href ) or return;
  
  
      ### return the object ###
      return $ff;
  }
  
  ### parses an uri to a hash structure:
  ###
  ### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
  ###
  ### becomes:
  ###
  ### $href = {
  ###     scheme  => 'ftp',
  ###     host    => 'ftp.cpan.org',
  ###     path    => '/pub/mirror',
  ###     file    => 'index.html'
  ### };
  ###
  ### In the case of file:// urls there maybe be additional fields
  ###
  ### For systems with volume specifications such as Win32 there will be
  ### a volume specifier provided in the 'vol' field.
  ###
  ###   'vol' => 'volumename'
  ###
  ### For windows file shares there may be a 'share' key specified
  ###
  ###   'share' => 'sharename'
  ###
  ### Note that the rules of what a file:// url means vary by the operating system
  ### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
  ### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
  ### not '/foo/bar.txt'
  ###
  ### Similarly if the host interpreting the url is VMS then
  ### file:///disk$user/my/notes/note12345.txt' means
  ### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
  ### if it is unix where it means /disk$user/my/notes/note12345.txt'.
  ### Except for some cases in the File::Spec methods, Perl on VMS will generally
  ### handle UNIX format file specifications.
  ###
  ### This means it is impossible to serve certain file:// urls on certain systems.
  ###
  ### Thus are the problems with a protocol-less specification. :-(
  ###
  
  sub _parse_uri {
      my $self = shift;
      my $uri  = shift or return;
  
      my $href = { uri => $uri };
  
      ### find the scheme ###
      $uri            =~ s|^(\w+)://||;
      $href->{scheme} = $1;
  
      ### See rfc 1738 section 3.10
      ### http://www.faqs.org/rfcs/rfc1738.html
      ### And wikipedia for more on windows file:// urls
      ### http://en.wikipedia.org/wiki/File://
      if( $href->{scheme} eq 'file' ) {
  
          my @parts = split '/',$uri;
  
          ### file://hostname/...
          ### file://hostname/...
          ### normalize file://localhost with file:///
          $href->{host} = $parts[0] || '';
  
          ### index in @parts where the path components begin;
          my $index = 1;
  
          ### file:////hostname/sharename/blah.txt
          if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
  
              $href->{host}   = $parts[2] || '';  # avoid warnings
              $href->{share}  = $parts[3] || '';  # avoid warnings
  
              $index          = 4         # index after the share
  
          ### file:///D|/blah.txt
          ### file:///D:/blah.txt
          } elsif (HAS_VOL) {
  
              ### this code comes from dmq's patch, but:
              ### XXX if volume is empty, wouldn't that be an error? --kane
              ### if so, our file://localhost test needs to be fixed as wel
              $href->{vol}    = $parts[1] || '';
  
              ### correct D| style colume descriptors
              $href->{vol}    =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
  
              $index          = 2;        # index after the volume
          }
  
          ### rebuild the path from the leftover parts;
          $href->{path} = join '/', '', splice( @parts, $index, $#parts );
  
      } else {
          ### using anything but qw() in hash slices may produce warnings
          ### in older perls :-(
          @{$href}{ qw(userinfo host path) } = $uri =~ m|(?:([^\@:]*:[^\:\@]*)@)?([^/]*)(/.*)$|s;
      }
  
      ### split the path into file + dir ###
      {   my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
          $href->{path} = $parts[1];
          $href->{file} = $parts[2];
      }
  
      ### host will be empty if the target was 'localhost' and the
      ### scheme was 'file'
      $href->{host} = '' if   ($href->{host}      eq 'localhost') and
                              ($href->{scheme}    eq 'file');
  
      return $href;
  }
  
  =head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] )
  
  Fetches the file you requested and returns the full path to the file.
  
  By default it writes to C<cwd()>, but you can override that by specifying
  the C<to> argument:
  
      ### file fetch to /tmp, full path to the file in $where
      $where = $ff->fetch( to => '/tmp' );
  
      ### file slurped into $scalar, full path to the file in $where
      ### file is downloaded to a temp directory and cleaned up at exit time
      $where = $ff->fetch( to => \$scalar );
  
  Returns the full path to the downloaded file on success, and false
  on failure.
  
  =cut
  
  sub fetch {
      my $self = shift or return;
      my %hash = @_;
  
      my $target;
      my $tmpl = {
          to  => { default => cwd(), store => \$target },
      };
  
      check( $tmpl, \%hash ) or return;
  
      my ($to, $fh);
      ### you want us to slurp the contents
      if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
          $to = tempdir( 'FileFetch.XXXXXX', DIR => $self->tempdir_root, CLEANUP => 1 );
  
      ### plain old fetch
      } else {
          $to = $target;
  
          ### On VMS force to VMS format so File::Spec will work.
          $to = VMS::Filespec::vmspath($to) if ON_VMS;
  
          ### create the path if it doesn't exist yet ###
          unless( -d $to ) {
              eval { mkpath( $to ) };
  
              return $self->_error(loc("Could not create path '%1'",$to)) if $@;
          }
      }
  
      ### set passive ftp if required ###
      local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
  
      ### we dont use catfile on win32 because if we are using a cygwin tool
      ### under cmd.exe they wont understand windows style separators.
      my $out_to = ON_WIN ? $to.'/'.$self->output_file
                          : File::Spec->catfile( $to, $self->output_file );
  
      for my $method ( @{ $METHODS->{$self->scheme} } ) {
          my $sub =  '_'.$method.'_fetch';
  
          unless( __PACKAGE__->can($sub) ) {
              $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
                          $method));
              next;
          }
  
          ### method is blacklisted ###
          next if grep { lc $_ eq $method } @$BLACKLIST;
  
          ### method is known to fail ###
          next if $METHOD_FAIL->{$method};
  
          ### there's serious issues with IPC::Run and quoting of command
          ### line arguments. using quotes in the wrong place breaks things,
          ### and in the case of say,
          ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
          ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
          ### it doesn't matter how you quote, it always fails.
          local $IPC::Cmd::USE_IPC_RUN = 0;
  
          if( my $file = $self->$sub(
                          to => $out_to
          )){
  
              unless( -e $file && -s _ ) {
                  $self->_error(loc("'%1' said it fetched '%2', ".
                       "but it was not created",$method,$file));
  
                  ### mark the failure ###
                  $METHOD_FAIL->{$method} = 1;
  
                  next;
  
              } else {
  
                  ### slurp mode?
                  if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
  
                      ### open the file
                      open my $fh, "<$file" or do {
                          $self->_error(
                              loc("Could not open '%1': %2", $file, $!));
                          return;
                      };
  
                      ### slurp
                      $$target = do { local $/; <$fh> };
  
                  }
  
                  my $abs = File::Spec->rel2abs( $file );
                  return $abs;
  
              }
          }
      }
  
  
      ### if we got here, we looped over all methods, but we weren't able
      ### to fetch it.
      return;
  }
  
  ########################
  ### _*_fetch methods ###
  ########################
  
  ### LWP fetching ###
  sub _lwp_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### modules required to download with lwp ###
      my $use_list = {
          LWP                 => '0.0',
          'LWP::UserAgent'    => '0.0',
          'HTTP::Request'     => '0.0',
          'HTTP::Status'      => '0.0',
          URI                 => '0.0',
  
      };
  
      if ($self->scheme eq 'https') {
          $use_list->{'LWP::Protocol::https'} = '0';
      }
  
      unless( can_load( modules => $use_list ) ) {
          $METHOD_FAIL->{'lwp'} = 1;
          return;
      }
  
      ### setup the uri object
      my $uri = URI->new( File::Spec::Unix->catfile(
                                  $self->path, $self->file
                      ) );
  
      ### special rules apply for file:// uris ###
      $uri->scheme( $self->scheme );
      $uri->host( $self->scheme eq 'file' ? '' : $self->host );
  
      if ($self->userinfo) {
          $uri->userinfo($self->userinfo);
      } elsif ($self->scheme ne 'file') {
          $uri->userinfo("anonymous:$FROM_EMAIL");
      }
  
      ### set up the useragent object
      my $ua = LWP::UserAgent->new();
      $ua->timeout( $TIMEOUT ) if $TIMEOUT;
      $ua->agent( $USER_AGENT );
      $ua->from( $FROM_EMAIL );
      $ua->env_proxy;
  
      my $res = $ua->mirror($uri, $to) or return;
  
      ### uptodate or fetched ok ###
      if ( $res->code == 304 or $res->code == 200 ) {
          return $to;
  
      } else {
          return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
                      $res->code, HTTP::Status::status_message($res->code),
                      $res->status_line));
      }
  
  }
  
  ### HTTP::Tiny fetching ###
  sub _httptiny_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      my $use_list = {
          'HTTP::Tiny'    => '0.008',
  
      };
  
      unless( can_load(modules => $use_list) ) {
          $METHOD_FAIL->{'httptiny'} = 1;
          return;
      }
  
      my $uri = $self->uri;
  
      my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );
  
      my $rc = $http->mirror( $uri, $to );
  
      unless ( $rc->{success} ) {
  
          return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
                      $rc->{status}, $rc->{reason} ) );
  
      }
  
      return $to;
  
  }
  
  ### HTTP::Lite fetching ###
  sub _httplite_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### modules required to download with lwp ###
      my $use_list = {
          'HTTP::Lite'    => '2.2',
          'MIME::Base64'  => '0',
      };
  
      unless( can_load(modules => $use_list) ) {
          $METHOD_FAIL->{'httplite'} = 1;
          return;
      }
  
      my $uri = $self->uri;
      my $retries = 0;
  
      RETRIES: while ( $retries++ < 5 ) {
  
        my $http = HTTP::Lite->new();
        # Naughty naughty but there isn't any accessor/setter
        $http->{timeout} = $TIMEOUT if $TIMEOUT;
        $http->http11_mode(1);
  
        if ($self->userinfo) {
            my $encoded = MIME::Base64::encode($self->userinfo, '');
            $http->add_req_header("Authorization", "Basic $encoded");
        }
  
        my $fh = FileHandle->new;
  
        unless ( $fh->open($to,'>') ) {
          return $self->_error(loc(
               "Could not open '%1' for writing: %2",$to,$!));
        }
  
        $fh->autoflush(1);
  
        binmode $fh;
  
        my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh );
  
        close $fh;
  
        if ( $rc == 301 || $rc == 302 ) {
            my $loc;
            HEADERS: for ($http->headers_array) {
              /Location: (\S+)/ and $loc = $1, last HEADERS;
            }
            #$loc or last; # Think we should squeal here.
            if ($loc =~ m!^/!) {
              $uri =~ s{^(\w+?://[^/]+)/.*$}{$1};
              $uri .= $loc;
            }
            else {
              $uri = $loc;
            }
            next RETRIES;
        }
        elsif ( $rc == 200 ) {
            return $to;
        }
        else {
          return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
                      $rc, $http->status_message));
        }
  
      } # Loop for 5 retries.
  
      return $self->_error("Fetch failed! Gave up after 5 tries");
  
  }
  
  ### Simple IO::Socket::INET fetching ###
  sub _iosock_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      my $use_list = {
          'IO::Socket::INET' => '0.0',
          'IO::Select'       => '0.0',
      };
  
      unless( can_load(modules => $use_list) ) {
          $METHOD_FAIL->{'iosock'} = 1;
          return;
      }
  
      my $sock = IO::Socket::INET->new(
          PeerHost => $self->host,
          ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
      );
  
      unless ( $sock ) {
          return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
      }
  
      my $fh = FileHandle->new;
  
      # Check open()
  
      unless ( $fh->open($to,'>') ) {
          return $self->_error(loc(
               "Could not open '%1' for writing: %2",$to,$!));
      }
  
      $fh->autoflush(1);
      binmode $fh;
  
      my $path = File::Spec::Unix->catfile( $self->path, $self->file );
      my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
      $sock->send( $req );
  
      my $select = IO::Select->new( $sock );
  
      my $resp = '';
      my $normal = 0;
      while ( $select->can_read( $TIMEOUT || 60 ) ) {
        my $ret = $sock->sysread( $resp, 4096, length($resp) );
        if ( !defined $ret or $ret == 0 ) {
          $select->remove( $sock );
          $normal++;
        }
      }
      close $sock;
  
      unless ( $normal ) {
          return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
      }
  
      # Check the "response"
      # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
      $resp =~ s/^(\x0d?\x0a)+//;
      # Check it is an HTTP response
      unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
          return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
      }
  
      # Check for OK
      my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
      unless ( $code eq '200' ) {
          return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
      }
  
      {
        local $\;
        print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
      }
      close $fh;
      return $to;
  }
  
  ### Net::FTP fetching
  sub _netftp_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### required modules ###
      my $use_list = { 'Net::FTP' => 0 };
  
      unless( can_load( modules => $use_list ) ) {
          $METHOD_FAIL->{'netftp'} = 1;
          return;
      }
  
      ### make connection ###
      my $ftp;
      my @options = ($self->host);
      push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
      unless( $ftp = Net::FTP->new( @options ) ) {
          return $self->_error(loc("Ftp creation failed: %1",$@));
      }
  
      ### login ###
      unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
          return $self->_error(loc("Could not login to '%1'",$self->host));
      }
  
      ### set binary mode, just in case ###
      $ftp->binary;
  
      ### create the remote path
      ### remember remote paths are unix paths! [#11483]
      my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
  
      ### fetch the file ###
      my $target;
      unless( $target = $ftp->get( $remote, $to ) ) {
          return $self->_error(loc("Could not fetch '%1' from '%2'",
                      $remote, $self->host));
      }
  
      ### log out ###
      $ftp->quit;
  
      return $target;
  
  }
  
  ### /bin/wget fetch ###
  sub _wget_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      my $wget;
      ### see if we have a wget binary ###
      unless( $wget = can_run('wget') ) {
          $METHOD_FAIL->{'wget'} = 1;
          return;
      }
  
      ### no verboseness, thanks ###
      my $cmd = [ $wget, '--quiet' ];
  
      ### if a timeout is set, add it ###
      push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
  
      ### run passive if specified ###
      push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
  
      ### set the output document, add the uri ###
      push @$cmd, '--output-document', $to, $self->uri;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? ($to, $self->uri)
      #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
  
      ### shell out ###
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG
      )) {
          ### wget creates the output document always, even if the fetch
          ### fails.. so unlink it in that case
          1 while unlink $to;
  
          return $self->_error(loc( "Command failed: %1", $captured || '' ));
      }
  
      return $to;
  }
  
  ### /bin/lftp fetch ###
  sub _lftp_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### see if we have a lftp binary ###
      my $lftp;
      unless( $lftp = can_run('lftp') ) {
          $METHOD_FAIL->{'lftp'} = 1;
          return;
      }
  
      ### no verboseness, thanks ###
      my $cmd = [ $lftp, '-f' ];
  
      my $fh = File::Temp->new;
  
      my $str;
  
      ### if a timeout is set, add it ###
      $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
  
      ### run passive if specified ###
      $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
  
      ### set the output document, add the uri ###
      ### quote the URI, because lftp supports certain shell
      ### expansions, most notably & for backgrounding.
      ### ' quote does nto work, must be "
      $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
  
      if( $DEBUG ) {
          my $pp_str = join ' ', split $/, $str;
          print "# lftp command: $pp_str\n";
      }
  
      ### write straight to the file.
      $fh->autoflush(1);
      print $fh $str;
  
      ### the command needs to be 1 string to be executed
      push @$cmd, $fh->filename;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? ($to, $self->uri)
      #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
  
  
      ### shell out ###
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG
      )) {
          ### wget creates the output document always, even if the fetch
          ### fails.. so unlink it in that case
          1 while unlink $to;
  
          return $self->_error(loc( "Command failed: %1", $captured || '' ));
      }
  
      return $to;
  }
  
  
  
  ### /bin/ftp fetch ###
  sub _ftp_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### see if we have a ftp binary ###
      my $ftp;
      unless( $ftp = can_run('ftp') ) {
          $METHOD_FAIL->{'ftp'} = 1;
          return;
      }
  
      my $fh = FileHandle->new;
  
      local $SIG{CHLD} = 'IGNORE';
  
      unless ($fh->open("$ftp -n", '|-')) {
          return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
      }
  
      my @dialog = (
          "lcd " . dirname($to),
          "open " . $self->host,
          "user anonymous $FROM_EMAIL",
          "cd /",
          "cd " . $self->path,
          "binary",
          "get " . $self->file . " " . $self->output_file,
          "quit",
      );
  
      foreach (@dialog) { $fh->print($_, "\n") }
      $fh->close or return;
  
      return $to;
  }
  
  ### lynx is stupid - it decompresses any .gz file it finds to be text
  ### use /bin/lynx to fetch files
  sub _lynx_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### see if we have a lynx binary ###
      my $lynx;
      unless ( $lynx = can_run('lynx') ){
          $METHOD_FAIL->{'lynx'} = 1;
          return;
      }
  
      unless( IPC::Cmd->can_capture_buffer ) {
          $METHOD_FAIL->{'lynx'} = 1;
  
          return $self->_error(loc(
              "Can not capture buffers. Can not use '%1' to fetch files",
              'lynx' ));
      }
  
      ### check if the HTTP resource exists ###
      if ($self->uri =~ /^https?:\/\//i) {
          my $cmd = [
              $lynx,
              '-head',
              '-source',
              "-auth=anonymous:$FROM_EMAIL",
          ];
  
          push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
  
          push @$cmd, $self->uri;
  
          ### shell out ###
          my $head;
          unless(run( command => $cmd,
                      buffer  => \$head,
                      verbose => $DEBUG )
          ) {
              return $self->_error(loc("Command failed: %1", $head || ''));
          }
  
          unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
              return $self->_error(loc("Command failed: %1", $head || ''));
          }
      }
  
      ### write to the output file ourselves, since lynx ass_u_mes to much
      my $local = FileHandle->new( $to, 'w' )
                      or return $self->_error(loc(
                          "Could not open '%1' for writing: %2",$to,$!));
  
      ### dump to stdout ###
      my $cmd = [
          $lynx,
          '-source',
          "-auth=anonymous:$FROM_EMAIL",
      ];
  
      push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
  
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      push @$cmd, $self->uri;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? $self->uri
      #    : QUOTE. $self->uri .QUOTE;
  
  
      ### shell out ###
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG )
      ) {
          return $self->_error(loc("Command failed: %1", $captured || ''));
      }
  
      ### print to local file ###
      ### XXX on a 404 with a special error page, $captured will actually
      ### hold the contents of that page, and make it *appear* like the
      ### request was a success, when really it wasn't :(
      ### there doesn't seem to be an option for lynx to change the exit
      ### code based on a 4XX status or so.
      ### the closest we can come is using --error_file and parsing that,
      ### which is very unreliable ;(
      $local->print( $captured );
      $local->close or return;
  
      return $to;
  }
  
  ### use /bin/ncftp to fetch files
  sub _ncftp_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### we can only set passive mode in interactive sessions, so bail out
      ### if $FTP_PASSIVE is set
      return if $FTP_PASSIVE;
  
      ### see if we have a ncftp binary ###
      my $ncftp;
      unless( $ncftp = can_run('ncftp') ) {
          $METHOD_FAIL->{'ncftp'} = 1;
          return;
      }
  
      my $cmd = [
          $ncftp,
          '-V',                   # do not be verbose
          '-p', $FROM_EMAIL,      # email as password
          $self->host,            # hostname
          dirname($to),           # local dir for the file
                                  # remote path to the file
          ### DO NOT quote things for IPC::Run, it breaks stuff.
          $IPC::Cmd::USE_IPC_RUN
                      ? File::Spec::Unix->catdir( $self->path, $self->file )
                      : QUOTE. File::Spec::Unix->catdir(
                                      $self->path, $self->file ) .QUOTE
  
      ];
  
      ### shell out ###
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG )
      ) {
          return $self->_error(loc("Command failed: %1", $captured || ''));
      }
  
      return $to;
  
  }
  
  ### use /bin/curl to fetch files
  sub _curl_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
      my $curl;
      unless ( $curl = can_run('curl') ) {
          $METHOD_FAIL->{'curl'} = 1;
          return;
      }
  
      ### these long opts are self explanatory - I like that -jmb
      my $cmd = [ $curl, '-q' ];
  
      push(@$cmd, '-4') if $^O eq 'netbsd' && $FORCEIPV4; # only seen this on NetBSD so far
  
      push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
  
      push(@$cmd, '--silent') unless $DEBUG;
  
      ### curl does the right thing with passive, regardless ###
      if ($self->scheme eq 'ftp') {
          push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
      }
  
      ### curl doesn't follow 302 (temporarily moved) etc automatically
      ### so we add --location to enable that.
      push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? ($to, $self->uri)
      #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
  
  
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG )
      ) {
  
          return $self->_error(loc("Command failed: %1", $captured || ''));
      }
  
      return $to;
  
  }
  
  ### /usr/bin/fetch fetch! ###
  sub _fetch_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
      ### see if we have a fetch binary ###
      my $fetch;
      unless( HAS_FETCH and $fetch = can_run('fetch') ) {
          $METHOD_FAIL->{'fetch'} = 1;
          return;
      }
  
      ### no verboseness, thanks ###
      my $cmd = [ $fetch, '-q' ];
  
      ### if a timeout is set, add it ###
      push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT;
  
      ### run passive if specified ###
      #push @$cmd, '-p' if $FTP_PASSIVE;
      local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE;
  
      ### set the output document, add the uri ###
      push @$cmd, '-o', $to, $self->uri;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? ($to, $self->uri)
      #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
  
      ### shell out ###
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG
      )) {
          ### wget creates the output document always, even if the fetch
          ### fails.. so unlink it in that case
          1 while unlink $to;
  
          return $self->_error(loc( "Command failed: %1", $captured || '' ));
      }
  
      return $to;
  }
  
  ### use File::Copy for fetching file:// urls ###
  ###
  ### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
  ### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
  ###
  
  sub _file_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
  
  
  
      ### prefix a / on unix systems with a file uri, since it would
      ### look somewhat like this:
      ###     file:///home/kane/file
      ### whereas windows file uris for 'c:\some\dir\file' might look like:
      ###     file:///C:/some/dir/file
      ###     file:///C|/some/dir/file
      ### or for a network share '\\host\share\some\dir\file':
      ###     file:////host/share/some/dir/file
      ###
      ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
      ###     file://vms.host.edu/disk$user/my/notes/note12345.txt
      ###
  
      my $path    = $self->path;
      my $vol     = $self->vol;
      my $share   = $self->share;
  
      my $remote;
      if (!$share and $self->host) {
          return $self->_error(loc(
              "Currently %1 cannot handle hosts in %2 urls",
              'File::Fetch', 'file://'
          ));
      }
  
      if( $vol ) {
          $path   = File::Spec->catdir( split /\//, $path );
          $remote = File::Spec->catpath( $vol, $path, $self->file);
  
      } elsif( $share ) {
          ### win32 specific, and a share name, so we wont bother with File::Spec
          $path   =~ s|/+|\\|g;
          $remote = "\\\\".$self->host."\\$share\\$path";
  
      } else {
          ### File::Spec on VMS can not currently handle UNIX syntax.
          my $file_class = ON_VMS
              ? 'File::Spec::Unix'
              : 'File::Spec';
  
          $remote  = $file_class->catfile( $path, $self->file );
      }
  
      ### File::Copy is littered with 'die' statements :( ###
      my $rv = eval { File::Copy::copy( $remote, $to ) };
  
      ### something went wrong ###
      if( !$rv or $@ ) {
          return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
                               $remote, $to, $!, $@));
      }
  
      return $to;
  }
  
  ### use /usr/bin/rsync to fetch files
  sub _rsync_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
      my $rsync;
      unless ( $rsync = can_run('rsync') ) {
          $METHOD_FAIL->{'rsync'} = 1;
          return;
      }
  
      my $cmd = [ $rsync ];
  
      ### XXX: rsync has no I/O timeouts at all, by default
      push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
  
      push(@$cmd, '--quiet') unless $DEBUG;
  
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      push @$cmd, $self->uri, $to;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? ($to, $self->uri)
      #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
  
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG )
      ) {
  
          return $self->_error(loc("Command %1 failed: %2",
              "@$cmd" || '', $captured || ''));
      }
  
      return $to;
  
  }
  
  ### use git to fetch files
  sub _git_fetch {
      my $self = shift;
      my %hash = @_;
  
      my ($to);
      my $tmpl = {
          to  => { required => 1, store => \$to }
      };
      check( $tmpl, \%hash ) or return;
      my $git;
      unless ( $git = can_run('git') ) {
          $METHOD_FAIL->{'git'} = 1;
          return;
      }
  
      my $cmd = [ $git, 'clone' ];
  
      #push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
  
      push(@$cmd, '--quiet') unless $DEBUG;
  
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      push @$cmd, $self->uri, $to;
  
      ### with IPC::Cmd > 0.41, this is fixed in teh library,
      ### and there's no need for special casing any more.
      ### DO NOT quote things for IPC::Run, it breaks stuff.
      # $IPC::Cmd::USE_IPC_RUN
      #    ? ($to, $self->uri)
      #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
  
      my $captured;
      unless(run( command => $cmd,
                  buffer  => \$captured,
                  verbose => $DEBUG )
      ) {
  
          return $self->_error(loc("Command %1 failed: %2",
              "@$cmd" || '', $captured || ''));
      }
  
      return $to;
  
  }
  
  #################################
  #
  # Error code
  #
  #################################
  
  =pod
  
  =head2 $ff->error([BOOL])
  
  Returns the last encountered error as string.
  Pass it a true value to get the C<Carp::longmess()> output instead.
  
  =cut
  
  ### error handling the way Archive::Extract does it
  sub _error {
      my $self    = shift;
      my $error   = shift;
  
      $self->_error_msg( $error );
      $self->_error_msg_long( Carp::longmess($error) );
  
      if( $WARN ) {
          carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
      }
  
      return;
  }
  
  sub error {
      my $self = shift;
      return shift() ? $self->_error_msg_long : $self->_error_msg;
  }
  
  
  1;
  
  =pod
  
  =head1 HOW IT WORKS
  
  File::Fetch is able to fetch a variety of uris, by using several
  external programs and modules.
  
  Below is a mapping of what utilities will be used in what order
  for what schemes, if available:
  
      file    => LWP, lftp, file
      http    => LWP, HTTP::Tiny, wget, curl, lftp, fetch, HTTP::Lite, lynx, iosock
      ftp     => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp
      rsync   => rsync
      git     => git
  
  If you'd like to disable the use of one or more of these utilities
  and/or modules, see the C<$BLACKLIST> variable further down.
  
  If a utility or module isn't available, it will be marked in a cache
  (see the C<$METHOD_FAIL> variable further down), so it will not be
  tried again. The C<fetch> method will only fail when all options are
  exhausted, and it was not able to retrieve the file.
  
  The C<fetch> utility is available on FreeBSD. NetBSD and Dragonfly BSD
  may also have it from C<pkgsrc>. We only check for C<fetch> on those
  three platforms.
  
  C<iosock> is a very limited L<IO::Socket::INET> based mechanism for
  retrieving C<http> schemed urls. It doesn't follow redirects for instance.
  
  C<git> only supports C<git://> style urls.
  
  A special note about fetching files from an ftp uri:
  
  By default, all ftp connections are done in passive mode. To change
  that, see the C<$FTP_PASSIVE> variable further down.
  
  Furthermore, ftp uris only support anonymous connections, so no
  named user/password pair can be passed along.
  
  C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
  further down.
  
  =head1 GLOBAL VARIABLES
  
  The behaviour of File::Fetch can be altered by changing the following
  global variables:
  
  =head2 $File::Fetch::FROM_EMAIL
  
  This is the email address that will be sent as your anonymous ftp
  password.
  
  Default is C<File-Fetch@example.com>.
  
  =head2 $File::Fetch::USER_AGENT
  
  This is the useragent as C<LWP> will report it.
  
  Default is C<File::Fetch/$VERSION>.
  
  =head2 $File::Fetch::FTP_PASSIVE
  
  This variable controls whether the environment variable C<FTP_PASSIVE>
  and any passive switches to commandline tools will be set to true.
  
  Default value is 1.
  
  Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
  files, since passive mode can only be set interactively for this binary
  
  =head2 $File::Fetch::TIMEOUT
  
  When set, controls the network timeout (counted in seconds).
  
  Default value is 0.
  
  =head2 $File::Fetch::WARN
  
  This variable controls whether errors encountered internally by
  C<File::Fetch> should be C<carp>'d or not.
  
  Set to false to silence warnings. Inspect the output of the C<error()>
  method manually to see what went wrong.
  
  Defaults to C<true>.
  
  =head2 $File::Fetch::DEBUG
  
  This enables debugging output when calling commandline utilities to
  fetch files.
  This also enables C<Carp::longmess> errors, instead of the regular
  C<carp> errors.
  
  Good for tracking down why things don't work with your particular
  setup.
  
  Default is 0.
  
  =head2 $File::Fetch::BLACKLIST
  
  This is an array ref holding blacklisted modules/utilities for fetching
  files with.
  
  To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
  set $File::Fetch::BLACKLIST to:
  
      $File::Fetch::BLACKLIST = [qw|lwp netftp|]
  
  The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
  
  See the note on C<MAPPING> below.
  
  =head2 $File::Fetch::METHOD_FAIL
  
  This is a hashref registering what modules/utilities were known to fail
  for fetching files (mostly because they weren't installed).
  
  You can reset this cache by assigning an empty hashref to it, or
  individually remove keys.
  
  See the note on C<MAPPING> below.
  
  =head1 MAPPING
  
  
  Here's a quick mapping for the utilities/modules, and their names for
  the $BLACKLIST, $METHOD_FAIL and other internal functions.
  
      LWP         => lwp
      HTTP::Lite  => httplite
      HTTP::Tiny  => httptiny
      Net::FTP    => netftp
      wget        => wget
      lynx        => lynx
      ncftp       => ncftp
      ftp         => ftp
      curl        => curl
      rsync       => rsync
      lftp        => lftp
      fetch       => fetch
      IO::Socket  => iosock
  
  =head1 FREQUENTLY ASKED QUESTIONS
  
  =head2 So how do I use a proxy with File::Fetch?
  
  C<File::Fetch> currently only supports proxies with LWP::UserAgent.
  You will need to set your environment variables accordingly. For
  example, to use an ftp proxy:
  
      $ENV{ftp_proxy} = 'foo.com';
  
  Refer to the LWP::UserAgent manpage for more details.
  
  =head2 I used 'lynx' to fetch a file, but its contents is all wrong!
  
  C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
  which we in turn capture. If that content is a 'custom' error file
  (like, say, a C<404 handler>), you will get that contents instead.
  
  Sadly, C<lynx> doesn't support any options to return a different exit
  code on non-C<200 OK> status, giving us no way to tell the difference
  between a 'successful' fetch and a custom error page.
  
  Therefor, we recommend to only use C<lynx> as a last resort. This is
  why it is at the back of our list of methods to try as well.
  
  =head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
  
  C<File::Fetch> is relatively smart about things. When trying to write
  a file to disk, it removes the C<query parameters> (see the
  C<output_file> method for details) from the file name before creating
  it. In most cases this suffices.
  
  If you have any other characters you need to escape, please install
  the C<URI::Escape> module from CPAN, and pre-encode your URI before
  passing it to C<File::Fetch>. You can read about the details of URIs
  and URI encoding here:
  
    http://www.faqs.org/rfcs/rfc2396.html
  
  =head1 TODO
  
  =over 4
  
  =item Implement $PREFER_BIN
  
  To indicate to rather use commandline tools than modules
  
  =back
  
  =head1 BUG REPORTS
  
  Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>.
  
  =head1 AUTHOR
  
  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
  
  =head1 COPYRIGHT
  
  This library is free software; you may redistribute and/or modify it
  under the same terms as Perl itself.
  
  
  =cut
  
  # Local variables:
  # c-indentation-style: bsd
  # c-basic-offset: 4
  # indent-tabs-mode: nil
  # End:
  # vim: expandtab shiftwidth=4:
  
  
  
  
FILE_FETCH

$fatpacked{"File/Path.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PATH';
  package File::Path;
  
  use 5.005_04;
  use strict;
  
  use Cwd 'getcwd';
  use File::Basename ();
  use File::Spec     ();
  
  BEGIN {
      if ( $] < 5.006 ) {
  
          # can't say 'opendir my $dh, $dirname'
          # need to initialise $dh
          eval 'use Symbol';
      }
  }
  
  use Exporter ();
  use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  $VERSION   = '2.15';
  $VERSION   = eval $VERSION;
  @ISA       = qw(Exporter);
  @EXPORT    = qw(mkpath rmtree);
  @EXPORT_OK = qw(make_path remove_tree);
  
  BEGIN {
    for (qw(VMS MacOS MSWin32 os2)) {
      no strict 'refs';
      *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
    }
  
    # These OSes complain if you want to remove a file that you have no
    # write permission to:
    *_FORCE_WRITABLE = (
      grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
    ) ? sub () { 1 } : sub () { 0 };
  
    # Unix-like systems need to stat each directory in order to detect
    # race condition. MS-Windows is immune to this particular attack.
    *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
  }
  
  sub _carp {
      require Carp;
      goto &Carp::carp;
  }
  
  sub _croak {
      require Carp;
      goto &Carp::croak;
  }
  
  sub _error {
      my $arg     = shift;
      my $message = shift;
      my $object  = shift;
  
      if ( $arg->{error} ) {
          $object = '' unless defined $object;
          $message .= ": $!" if $!;
          push @{ ${ $arg->{error} } }, { $object => $message };
      }
      else {
          _carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
      }
  }
  
  sub __is_arg {
      my ($arg) = @_;
  
      # If client code blessed an array ref to HASH, this will not work
      # properly. We could have done $arg->isa() wrapped in eval, but
      # that would be expensive. This implementation should suffice.
      # We could have also used Scalar::Util:blessed, but we choose not
      # to add this dependency
      return ( ref $arg eq 'HASH' );
  }
  
  sub make_path {
      push @_, {} unless @_ and __is_arg( $_[-1] );
      goto &mkpath;
  }
  
  sub mkpath {
      my $old_style = !( @_ and __is_arg( $_[-1] ) );
  
      my $data;
      my $paths;
  
      if ($old_style) {
          my ( $verbose, $mode );
          ( $paths, $verbose, $mode ) = @_;
          $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
          $data->{verbose} = $verbose;
          $data->{mode} = defined $mode ? $mode : oct '777';
      }
      else {
          my %args_permitted = map { $_ => 1 } ( qw|
              chmod
              error
              group
              mask
              mode
              owner
              uid
              user
              verbose
          | );
          my %not_on_win32_args = map { $_ => 1 } ( qw|
              group
              owner
              uid
              user
          | );
          my @bad_args = ();
          my @win32_implausible_args = ();
          my $arg = pop @_;
          for my $k (sort keys %{$arg}) {
              if (! $args_permitted{$k}) {
                  push @bad_args, $k;
              }
              elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
                  push @win32_implausible_args, $k;
              }
              else {
                  $data->{$k} = $arg->{$k};
              }
          }
          _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
              if @bad_args;
          _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
              if @win32_implausible_args;
          $data->{mode} = delete $data->{mask} if exists $data->{mask};
          $data->{mode} = oct '777' unless exists $data->{mode};
          ${ $data->{error} } = [] if exists $data->{error};
          unless (@win32_implausible_args) {
              $data->{owner} = delete $data->{user} if exists $data->{user};
              $data->{owner} = delete $data->{uid}  if exists $data->{uid};
              if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
                  my $uid = ( getpwnam $data->{owner} )[2];
                  if ( defined $uid ) {
                      $data->{owner} = $uid;
                  }
                  else {
                      _error( $data,
                              "unable to map $data->{owner} to a uid, ownership not changed"
                            );
                      delete $data->{owner};
                  }
              }
              if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
                  my $gid = ( getgrnam $data->{group} )[2];
                  if ( defined $gid ) {
                      $data->{group} = $gid;
                  }
                  else {
                      _error( $data,
                              "unable to map $data->{group} to a gid, group ownership not changed"
                      );
                      delete $data->{group};
                  }
              }
              if ( exists $data->{owner} and not exists $data->{group} ) {
                  $data->{group} = -1;    # chown will leave group unchanged
              }
              if ( exists $data->{group} and not exists $data->{owner} ) {
                  $data->{owner} = -1;    # chown will leave owner unchanged
              }
          }
          $paths = [@_];
      }
      return _mkpath( $data, $paths );
  }
  
  sub _mkpath {
      my $data   = shift;
      my $paths = shift;
  
      my ( @created );
      foreach my $path ( @{$paths} ) {
          next unless defined($path) and length($path);
          $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
  
          # Logic wants Unix paths, so go with the flow.
          if (_IS_VMS) {
              next if $path eq '/';
              $path = VMS::Filespec::unixify($path);
          }
          next if -d $path;
          my $parent = File::Basename::dirname($path);
          # Coverage note:  It's not clear how we would test the condition:
          # '-d $parent or $path eq $parent'
          unless ( -d $parent or $path eq $parent ) {
              push( @created, _mkpath( $data, [$parent] ) );
          }
          print "mkdir $path\n" if $data->{verbose};
          if ( mkdir( $path, $data->{mode} ) ) {
              push( @created, $path );
              if ( exists $data->{owner} ) {
  
                  # NB: $data->{group} guaranteed to be set during initialisation
                  if ( !chown $data->{owner}, $data->{group}, $path ) {
                      _error( $data,
                          "Cannot change ownership of $path to $data->{owner}:$data->{group}"
                      );
                  }
              }
              if ( exists $data->{chmod} ) {
                  # Coverage note:  It's not clear how we would trigger the next
                  # 'if' block.  Failure of 'chmod' might first result in a
                  # system error: "Permission denied".
                  if ( !chmod $data->{chmod}, $path ) {
                      _error( $data,
                          "Cannot change permissions of $path to $data->{chmod}" );
                  }
              }
          }
          else {
              my $save_bang = $!;
  
              # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
              # as:
              # Error information specific to the current operating system. At the
              # moment, this differs from "$!" under only VMS, OS/2, and Win32
              # (and for MacPerl). On all other platforms, $^E is always just the
              # same as $!.
  
              my ( $e, $e1 ) = ( $save_bang, $^E );
              $e .= "; $e1" if $e ne $e1;
  
              # allow for another process to have created it meanwhile
              if ( ! -d $path ) {
                  $! = $save_bang;
                  if ( $data->{error} ) {
                      push @{ ${ $data->{error} } }, { $path => $e };
                  }
                  else {
                      _croak("mkdir $path: $e");
                  }
              }
          }
      }
      return @created;
  }
  
  sub remove_tree {
      push @_, {} unless @_ and __is_arg( $_[-1] );
      goto &rmtree;
  }
  
  sub _is_subdir {
      my ( $dir, $test ) = @_;
  
      my ( $dv, $dd ) = File::Spec->splitpath( $dir,  1 );
      my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
  
      # not on same volume
      return 0 if $dv ne $tv;
  
      my @d = File::Spec->splitdir($dd);
      my @t = File::Spec->splitdir($td);
  
      # @t can't be a subdir if it's shorter than @d
      return 0 if @t < @d;
  
      return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
  }
  
  sub rmtree {
      my $old_style = !( @_ and __is_arg( $_[-1] ) );
  
      my ($arg, $data, $paths);
  
      if ($old_style) {
          my ( $verbose, $safe );
          ( $paths, $verbose, $safe ) = @_;
          $data->{verbose} = $verbose;
          $data->{safe} = defined $safe ? $safe : 0;
  
          if ( defined($paths) and length($paths) ) {
              $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
          }
          else {
              _carp("No root path(s) specified\n");
              return 0;
          }
      }
      else {
          my %args_permitted = map { $_ => 1 } ( qw|
              error
              keep_root
              result
              safe
              verbose
          | );
          my @bad_args = ();
          my $arg = pop @_;
          for my $k (sort keys %{$arg}) {
              if (! $args_permitted{$k}) {
                  push @bad_args, $k;
              }
              else {
                  $data->{$k} = $arg->{$k};
              }
          }
          _carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
              if @bad_args;
          ${ $data->{error} }  = [] if exists $data->{error};
          ${ $data->{result} } = [] if exists $data->{result};
  
          # Wouldn't it make sense to do some validation on @_ before assigning
          # to $paths here?
          # In the $old_style case we guarantee that each path is both defined
          # and non-empty.  We don't check that here, which means we have to
          # check it later in the first condition in this line:
          #     if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
          # Granted, that would be a change in behavior for the two
          # non-old-style interfaces.
  
          $paths = [@_];
      }
  
      $data->{prefix} = '';
      $data->{depth}  = 0;
  
      my @clean_path;
      $data->{cwd} = getcwd() or do {
          _error( $data, "cannot fetch initial working directory" );
          return 0;
      };
      for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 }    # untaint
  
      for my $p (@$paths) {
  
          # need to fixup case and map \ to / on Windows
          my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
          my $ortho_cwd =
            _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
          my $ortho_root_length = length($ortho_root);
          $ortho_root_length-- if _IS_VMS;   # don't compare '.' with ']'
          if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
              local $! = 0;
              _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
              next;
          }
  
          if (_IS_MACOS) {
              $p = ":$p" unless $p =~ /:/;
              $p .= ":" unless $p =~ /:\z/;
          }
          elsif ( _IS_MSWIN32 ) {
              $p =~ s{[/\\]\z}{};
          }
          else {
              $p =~ s{/\z}{};
          }
          push @clean_path, $p;
      }
  
      @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
          _error( $data, "cannot stat initial working directory", $data->{cwd} );
          return 0;
      };
  
      return _rmtree( $data, \@clean_path );
  }
  
  sub _rmtree {
      my $data   = shift;
      my $paths = shift;
  
      my $count  = 0;
      my $curdir = File::Spec->curdir();
      my $updir  = File::Spec->updir();
  
      my ( @files, $root );
    ROOT_DIR:
      foreach my $root (@$paths) {
  
          # since we chdir into each directory, it may not be obvious
          # to figure out where we are if we generate a message about
          # a file name. We therefore construct a semi-canonical
          # filename, anchored from the directory being unlinked (as
          # opposed to being truly canonical, anchored from the root (/).
  
          my $canon =
            $data->{prefix}
            ? File::Spec->catfile( $data->{prefix}, $root )
            : $root;
  
          my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
            or next ROOT_DIR;
  
          if ( -d _ ) {
              $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
                if _IS_VMS;
  
              if ( !chdir($root) ) {
  
                  # see if we can escalate privileges to get in
                  # (e.g. funny protection mask such as -w- instead of rwx)
                  # This uses fchmod to avoid traversing outside of the proper
                  # location (CVE-2017-6512)
                  my $root_fh;
                  if (open($root_fh, '<', $root)) {
                      my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
                      $perm &= oct '7777';
                      my $nperm = $perm | oct '700';
                      local $@;
                      if (
                          !(
                              $data->{safe}
                             or $nperm == $perm
                             or !-d _
                             or $fh_dev ne $ldev
                             or $fh_inode ne $lino
                             or eval { chmod( $nperm, $root_fh ) }
                          )
                        )
                      {
                          _error( $data,
                              "cannot make child directory read-write-exec", $canon );
                          next ROOT_DIR;
                      }
                      close $root_fh;
                  }
                  if ( !chdir($root) ) {
                      _error( $data, "cannot chdir to child", $canon );
                      next ROOT_DIR;
                  }
              }
  
              my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
                or do {
                  _error( $data, "cannot stat current working directory", $canon );
                  next ROOT_DIR;
                };
  
              if (_NEED_STAT_CHECK) {
                  ( $ldev eq $cur_dev and $lino eq $cur_inode )
                    or _croak(
  "directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
                    );
              }
  
              $perm &= oct '7777';    # don't forget setuid, setgid, sticky bits
              my $nperm = $perm | oct '700';
  
              # notabene: 0700 is for making readable in the first place,
              # it's also intended to change it to writable in case we have
              # to recurse in which case we are better than rm -rf for
              # subtrees with strange permissions
  
              if (
                  !(
                         $data->{safe}
                      or $nperm == $perm
                      or chmod( $nperm, $curdir )
                  )
                )
              {
                  _error( $data, "cannot make directory read+writeable", $canon );
                  $nperm = $perm;
              }
  
              my $d;
              $d = gensym() if $] < 5.006;
              if ( !opendir $d, $curdir ) {
                  _error( $data, "cannot opendir", $canon );
                  @files = ();
              }
              else {
                  if ( !defined ${^TAINT} or ${^TAINT} ) {
                      # Blindly untaint dir names if taint mode is active
                      @files = map { /\A(.*)\z/s; $1 } readdir $d;
                  }
                  else {
                      @files = readdir $d;
                  }
                  closedir $d;
              }
  
              if (_IS_VMS) {
  
                  # Deleting large numbers of files from VMS Files-11
                  # filesystems is faster if done in reverse ASCIIbetical order.
                  # include '.' to '.;' from blead patch #31775
                  @files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
              }
  
              @files = grep { $_ ne $updir and $_ ne $curdir } @files;
  
              if (@files) {
  
                  # remove the contained files before the directory itself
                  my $narg = {%$data};
                  @{$narg}{qw(device inode cwd prefix depth)} =
                    ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
                  $count += _rmtree( $narg, \@files );
              }
  
              # restore directory permissions of required now (in case the rmdir
              # below fails), while we are still in the directory and may do so
              # without a race via '.'
              if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
                  _error( $data, "cannot reset chmod", $canon );
              }
  
              # don't leave the client code in an unexpected directory
              chdir( $data->{cwd} )
                or
                _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting.");
  
              # ensure that a chdir upwards didn't take us somewhere other
              # than we expected (see CVE-2002-0435)
              ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
                or _croak(
                  "cannot stat prior working directory $data->{cwd}: $!, aborting."
                );
  
              if (_NEED_STAT_CHECK) {
                  ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode )
                    or _croak(  "previous directory $data->{cwd} "
                              . "changed before entering $canon, "
                              . "expected dev=$ldev ino=$lino, "
                              . "actual dev=$cur_dev ino=$cur_inode, aborting."
                    );
              }
  
              if ( $data->{depth} or !$data->{keep_root} ) {
                  if ( $data->{safe}
                      && ( _IS_VMS
                          ? !&VMS::Filespec::candelete($root)
                          : !-w $root ) )
                  {
                      print "skipped $root\n" if $data->{verbose};
                      next ROOT_DIR;
                  }
                  if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
                      _error( $data, "cannot make directory writeable", $canon );
                  }
                  print "rmdir $root\n" if $data->{verbose};
                  if ( rmdir $root ) {
                      push @{ ${ $data->{result} } }, $root if $data->{result};
                      ++$count;
                  }
                  else {
                      _error( $data, "cannot remove directory", $canon );
                      if (
                          _FORCE_WRITABLE
                          && !chmod( $perm,
                              ( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
                          )
                        )
                      {
                          _error(
                              $data,
                              sprintf( "cannot restore permissions to 0%o",
                                  $perm ),
                              $canon
                          );
                      }
                  }
              }
          }
          else {
              # not a directory
              $root = VMS::Filespec::vmsify("./$root")
                if _IS_VMS
                && !File::Spec->file_name_is_absolute($root)
                && ( $root !~ m/(?<!\^)[\]>]+/ );    # not already in VMS syntax
  
              if (
                  $data->{safe}
                  && (
                      _IS_VMS
                      ? !&VMS::Filespec::candelete($root)
                      : !( -l $root || -w $root )
                  )
                )
              {
                  print "skipped $root\n" if $data->{verbose};
                  next ROOT_DIR;
              }
  
              my $nperm = $perm & oct '7777' | oct '600';
              if (    _FORCE_WRITABLE
                  and $nperm != $perm
                  and not chmod $nperm, $root )
              {
                  _error( $data, "cannot make file writeable", $canon );
              }
              print "unlink $canon\n" if $data->{verbose};
  
              # delete all versions under VMS
              for ( ; ; ) {
                  if ( unlink $root ) {
                      push @{ ${ $data->{result} } }, $root if $data->{result};
                  }
                  else {
                      _error( $data, "cannot unlink file", $canon );
                      _FORCE_WRITABLE and chmod( $perm, $root )
                        or _error( $data,
                          sprintf( "cannot restore permissions to 0%o", $perm ),
                          $canon );
                      last;
                  }
                  ++$count;
                  last unless _IS_VMS && lstat $root;
              }
          }
      }
      return $count;
  }
  
  sub _slash_lc {
  
      # fix up slashes and case on MSWin32 so that we can determine that
      # c:\path\to\dir is underneath C:/Path/To
      my $path = shift;
      $path =~ tr{\\}{/};
      return lc($path);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  File::Path - Create or remove directory trees
  
  =head1 VERSION
  
  2.15 - released June 07 2017.
  
  =head1 SYNOPSIS
  
      use File::Path qw(make_path remove_tree);
  
      @created = make_path('foo/bar/baz', '/zug/zwang');
      @created = make_path('foo/bar/baz', '/zug/zwang', {
          verbose => 1,
          mode => 0711,
      });
      make_path('foo/bar/baz', '/zug/zwang', {
          chmod => 0777,
      });
  
      $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', {
          verbose => 1,
          error  => \my $err_list,
          safe => 1,
      });
  
      # legacy (interface promoted before v2.00)
      @created = mkpath('/foo/bar/baz');
      @created = mkpath('/foo/bar/baz', 1, 0711);
      @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
      $removed_count = rmtree('foo/bar/baz', 1, 1);
      $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
  
      # legacy (interface promoted before v2.06)
      @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
      $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
  
  =head1 DESCRIPTION
  
  This module provides a convenient way to create directories of
  arbitrary depth and to delete an entire directory subtree from the
  filesystem.
  
  The following functions are provided:
  
  =over
  
  =item make_path( $dir1, $dir2, .... )
  
  =item make_path( $dir1, $dir2, ...., \%opts )
  
  The C<make_path> function creates the given directories if they don't
  exist before, much like the Unix command C<mkdir -p>.
  
  The function accepts a list of directories to be created. Its
  behaviour may be tuned by an optional hashref appearing as the last
  parameter on the call.
  
  The function returns the list of directories actually created during
  the call; in scalar context the number of directories created.
  
  The following keys are recognised in the option hash:
  
  =over
  
  =item mode => $num
  
  The numeric permissions mode to apply to each created directory
  (defaults to C<0777>), to be modified by the current C<umask>. If the
  directory already exists (and thus does not need to be created),
  the permissions will not be modified.
  
  C<mask> is recognised as an alias for this parameter.
  
  =item chmod => $num
  
  Takes a numeric mode to apply to each created directory (not
  modified by the current C<umask>). If the directory already exists
  (and thus does not need to be created), the permissions will
  not be modified.
  
  =item verbose => $bool
  
  If present, will cause C<make_path> to print the name of each directory
  as it is created. By default nothing is printed.
  
  =item error => \$err
  
  If present, it should be a reference to a scalar.
  This scalar will be made to reference an array, which will
  be used to store any errors that are encountered.  See the L</"ERROR
  HANDLING"> section for more information.
  
  If this parameter is not used, certain error conditions may raise
  a fatal error that will cause the program to halt, unless trapped
  in an C<eval> block.
  
  =item owner => $owner
  
  =item user => $owner
  
  =item uid => $owner
  
  If present, will cause any created directory to be owned by C<$owner>.
  If the value is numeric, it will be interpreted as a uid; otherwise a
  username is assumed. An error will be issued if the username cannot be
  mapped to a uid, the uid does not exist or the process lacks the
  privileges to change ownership.
  
  Ownership of directories that already exist will not be changed.
  
  C<user> and C<uid> are aliases of C<owner>.
  
  =item group => $group
  
  If present, will cause any created directory to be owned by the group
  C<$group>.  If the value is numeric, it will be interpreted as a gid;
  otherwise a group name is assumed. An error will be issued if the
  group name cannot be mapped to a gid, the gid does not exist or the
  process lacks the privileges to change group ownership.
  
  Group ownership of directories that already exist will not be changed.
  
      make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
  
  =back
  
  =item mkpath( $dir )
  
  =item mkpath( $dir, $verbose, $mode )
  
  =item mkpath( [$dir1, $dir2,...], $verbose, $mode )
  
  =item mkpath( $dir1, $dir2,..., \%opt )
  
  The C<mkpath()> function provide the legacy interface of
  C<make_path()> with a different interpretation of the arguments
  passed.  The behaviour and return value of the function is otherwise
  identical to C<make_path()>.
  
  =item remove_tree( $dir1, $dir2, .... )
  
  =item remove_tree( $dir1, $dir2, ...., \%opts )
  
  The C<remove_tree> function deletes the given directories and any
  files and subdirectories they might contain, much like the Unix
  command C<rm -rf> or the Windows commands C<rmdir /s> and C<rd /s>.
  
  The function accepts a list of directories to be removed. (In point of fact,
  it will also accept filesystem entries which are not directories, such as
  regular files and symlinks.  But, as its name suggests, its intent is to
  remove trees rather than individual files.)
  
  C<remove_tree()>'s behaviour may be tuned by an optional hashref
  appearing as the last parameter on the call.  If an empty string is
  passed to C<remove_tree>, an error will occur.
  
  B<NOTE:>  For security reasons, we strongly advise use of the
  hashref-as-final-argument syntax -- specifically, with a setting of the C<safe>
  element to a true value.
  
      remove_tree( $dir1, $dir2, ....,
          {
              safe => 1,
              ...         # other key-value pairs
          },
      );
  
  The function returns the number of files successfully deleted.
  
  The following keys are recognised in the option hash:
  
  =over
  
  =item verbose => $bool
  
  If present, will cause C<remove_tree> to print the name of each file as
  it is unlinked. By default nothing is printed.
  
  =item safe => $bool
  
  When set to a true value, will cause C<remove_tree> to skip the files
  for which the process lacks the required privileges needed to delete
  files, such as delete privileges on VMS. In other words, the code
  will make no attempt to alter file permissions. Thus, if the process
  is interrupted, no filesystem object will be left in a more
  permissive mode.
  
  =item keep_root => $bool
  
  When set to a true value, will cause all files and subdirectories
  to be removed, except the initially specified directories. This comes
  in handy when cleaning out an application's scratch directory.
  
      remove_tree( '/tmp', {keep_root => 1} );
  
  =item result => \$res
  
  If present, it should be a reference to a scalar.
  This scalar will be made to reference an array, which will
  be used to store all files and directories unlinked
  during the call. If nothing is unlinked, the array will be empty.
  
      remove_tree( '/tmp', {result => \my $list} );
      print "unlinked $_\n" for @$list;
  
  This is a useful alternative to the C<verbose> key.
  
  =item error => \$err
  
  If present, it should be a reference to a scalar.
  This scalar will be made to reference an array, which will
  be used to store any errors that are encountered.  See the L</"ERROR
  HANDLING"> section for more information.
  
  Removing things is a much more dangerous proposition than
  creating things. As such, there are certain conditions that
  C<remove_tree> may encounter that are so dangerous that the only
  sane action left is to kill the program.
  
  Use C<error> to trap all that is reasonable (problems with
  permissions and the like), and let it die if things get out
  of hand. This is the safest course of action.
  
  =back
  
  =item rmtree( $dir )
  
  =item rmtree( $dir, $verbose, $safe )
  
  =item rmtree( [$dir1, $dir2,...], $verbose, $safe )
  
  =item rmtree( $dir1, $dir2,..., \%opt )
  
  The C<rmtree()> function provide the legacy interface of
  C<remove_tree()> with a different interpretation of the arguments
  passed. The behaviour and return value of the function is otherwise
  identical to C<remove_tree()>.
  
  B<NOTE:>  For security reasons, we strongly advise use of the
  hashref-as-final-argument syntax, specifically with a setting of the C<safe>
  element to a true value.
  
      rmtree( $dir1, $dir2, ....,
          {
              safe => 1,
              ...         # other key-value pairs
          },
      );
  
  =back
  
  =head2 ERROR HANDLING
  
  =over 4
  
  =item B<NOTE:>
  
  The following error handling mechanism is consistent throughout all
  code paths EXCEPT in cases where the ROOT node is nonexistent.  In
  version 2.11 the maintainers attempted to rectify this inconsistency
  but too many downstream modules encountered problems.  In such case,
  if you require root node evaluation or error checking prior to calling
  C<make_path> or C<remove_tree>, you should take additional precautions.
  
  =back
  
  If C<make_path> or C<remove_tree> encounters an error, a diagnostic
  message will be printed to C<STDERR> via C<carp> (for non-fatal
  errors) or via C<croak> (for fatal errors).
  
  If this behaviour is not desirable, the C<error> attribute may be
  used to hold a reference to a variable, which will be used to store
  the diagnostics. The variable is made a reference to an array of hash
  references.  Each hash contain a single key/value pair where the key
  is the name of the file, and the value is the error message (including
  the contents of C<$!> when appropriate).  If a general error is
  encountered the diagnostic key will be empty.
  
  An example usage looks like:
  
    remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
    if ($err && @$err) {
        for my $diag (@$err) {
            my ($file, $message) = %$diag;
            if ($file eq '') {
                print "general error: $message\n";
            }
            else {
                print "problem unlinking $file: $message\n";
            }
        }
    }
    else {
        print "No error encountered\n";
    }
  
  Note that if no errors are encountered, C<$err> will reference an
  empty array.  This means that C<$err> will always end up TRUE; so you
  need to test C<@$err> to determine if errors occurred.
  
  =head2 NOTES
  
  C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
  current namespace. These days, this is considered bad style, but
  to change it now would break too much code. Nonetheless, you are
  invited to specify what it is you are expecting to use:
  
    use File::Path 'rmtree';
  
  The routines C<make_path> and C<remove_tree> are B<not> exported
  by default. You must specify which ones you want to use.
  
    use File::Path 'remove_tree';
  
  Note that a side-effect of the above is that C<mkpath> and C<rmtree>
  are no longer exported at all. This is due to the way the C<Exporter>
  module works. If you are migrating a codebase to use the new
  interface, you will have to list everything explicitly. But that's
  just good practice anyway.
  
    use File::Path qw(remove_tree rmtree);
  
  =head3 API CHANGES
  
  The API was changed in the 2.0 branch. For a time, C<mkpath> and
  C<rmtree> tried, unsuccessfully, to deal with the two different
  calling mechanisms. This approach was considered a failure.
  
  The new semantics are now only available with C<make_path> and
  C<remove_tree>. The old semantics are only available through
  C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
  to at least 2.08 in order to avoid surprises.
  
  =head3 SECURITY CONSIDERATIONS
  
  There were race conditions in the 1.x implementations of File::Path's
  C<rmtree> function (although sometimes patched depending on the OS
  distribution or platform). The 2.0 version contains code to avoid the
  problem mentioned in CVE-2002-0435.
  
  See the following pages for more information:
  
      http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
      http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
      http://www.debian.org/security/2005/dsa-696
  
  Additionally, unless the C<safe> parameter is set (or the
  third parameter in the traditional interface is TRUE), should a
  C<remove_tree> be interrupted, files that were originally in read-only
  mode may now have their permissions set to a read-write (or "delete
  OK") mode.
  
  The following CVE reports were previously filed against File-Path and are
  believed to have been addressed:
  
  =over 4
  
  =item * L<http://cve.circl.lu/cve/CVE-2004-0452>
  
  =item * L<http://cve.circl.lu/cve/CVE-2005-0448>
  
  =back
  
  In February 2017 the cPanel Security Team reported an additional vulnerability
  in File-Path.  The C<chmod()> logic to make directories traversable can be
  abused to set the mode on an attacker-chosen file to an attacker-chosen value.
  This is due to the time-of-check-to-time-of-use (TOCTTOU) race condition
  (L<https://en.wikipedia.org/wiki/Time_of_check_to_time_of_use>) between the
  C<stat()> that decides the inode is a directory and the C<chmod()> that tries
  to make it user-rwx.  CPAN versions 2.13 and later incorporate a patch
  provided by John Lightsey to address this problem.  This vulnerability has
  been reported as CVE-2017-6512.
  
  =head1 DIAGNOSTICS
  
  FATAL errors will cause the program to halt (C<croak>), since the
  problem is so severe that it would be dangerous to continue. (This
  can always be trapped with C<eval>, but it's not a good idea. Under
  the circumstances, dying is the best thing to do).
  
  SEVERE errors may be trapped using the modern interface. If the
  they are not trapped, or if the old interface is used, such an error
  will cause the program will halt.
  
  All other errors may be trapped using the modern interface, otherwise
  they will be C<carp>ed about. Program execution will not be halted.
  
  =over 4
  
  =item mkdir [path]: [errmsg] (SEVERE)
  
  C<make_path> was unable to create the path. Probably some sort of
  permissions error at the point of departure or insufficient resources
  (such as free inodes on Unix).
  
  =item No root path(s) specified
  
  C<make_path> was not given any paths to create. This message is only
  emitted if the routine is called with the traditional interface.
  The modern interface will remain silent if given nothing to do.
  
  =item No such file or directory
  
  On Windows, if C<make_path> gives you this warning, it may mean that
  you have exceeded your filesystem's maximum path length.
  
  =item cannot fetch initial working directory: [errmsg]
  
  C<remove_tree> attempted to determine the initial directory by calling
  C<Cwd::getcwd>, but the call failed for some reason. No attempt
  will be made to delete anything.
  
  =item cannot stat initial working directory: [errmsg]
  
  C<remove_tree> attempted to stat the initial directory (after having
  successfully obtained its name via C<getcwd>), however, the call
  failed for some reason. No attempt will be made to delete anything.
  
  =item cannot chdir to [dir]: [errmsg]
  
  C<remove_tree> attempted to set the working directory in order to
  begin deleting the objects therein, but was unsuccessful. This is
  usually a permissions issue. The routine will continue to delete
  other things, but this directory will be left intact.
  
  =item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
  
  C<remove_tree> recorded the device and inode of a directory, and then
  moved into it. It then performed a C<stat> on the current directory
  and detected that the device and inode were no longer the same. As
  this is at the heart of the race condition problem, the program
  will die at this point.
  
  =item cannot make directory [dir] read+writeable: [errmsg]
  
  C<remove_tree> attempted to change the permissions on the current directory
  to ensure that subsequent unlinkings would not run into problems,
  but was unable to do so. The permissions remain as they were, and
  the program will carry on, doing the best it can.
  
  =item cannot read [dir]: [errmsg]
  
  C<remove_tree> tried to read the contents of the directory in order
  to acquire the names of the directory entries to be unlinked, but
  was unsuccessful. This is usually a permissions issue. The
  program will continue, but the files in this directory will remain
  after the call.
  
  =item cannot reset chmod [dir]: [errmsg]
  
  C<remove_tree>, after having deleted everything in a directory, attempted
  to restore its permissions to the original state but failed. The
  directory may wind up being left behind.
  
  =item cannot remove [dir] when cwd is [dir]
  
  The current working directory of the program is F</some/path/to/here>
  and you are attempting to remove an ancestor, such as F</some/path>.
  The directory tree is left untouched.
  
  The solution is to C<chdir> out of the child directory to a place
  outside the directory tree to be removed.
  
  =item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
  
  C<remove_tree>, after having deleted everything and restored the permissions
  of a directory, was unable to chdir back to the parent. The program
  halts to avoid a race condition from occurring.
  
  =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
  
  C<remove_tree> was unable to stat the parent directory after having returned
  from the child. Since there is no way of knowing if we returned to
  where we think we should be (by comparing device and inode) the only
  way out is to C<croak>.
  
  =item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
  
  When C<remove_tree> returned from deleting files in a child directory, a
  check revealed that the parent directory it returned to wasn't the one
  it started out from. This is considered a sign of malicious activity.
  
  =item cannot make directory [dir] writeable: [errmsg]
  
  Just before removing a directory (after having successfully removed
  everything it contained), C<remove_tree> attempted to set the permissions
  on the directory to ensure it could be removed and failed. Program
  execution continues, but the directory may possibly not be deleted.
  
  =item cannot remove directory [dir]: [errmsg]
  
  C<remove_tree> attempted to remove a directory, but failed. This may be because
  some objects that were unable to be removed remain in the directory, or
  it could be a permissions issue. The directory will be left behind.
  
  =item cannot restore permissions of [dir] to [0nnn]: [errmsg]
  
  After having failed to remove a directory, C<remove_tree> was unable to
  restore its permissions from a permissive state back to a possibly
  more restrictive setting. (Permissions given in octal).
  
  =item cannot make file [file] writeable: [errmsg]
  
  C<remove_tree> attempted to force the permissions of a file to ensure it
  could be deleted, but failed to do so. It will, however, still attempt
  to unlink the file.
  
  =item cannot unlink file [file]: [errmsg]
  
  C<remove_tree> failed to remove a file. Probably a permissions issue.
  
  =item cannot restore permissions of [file] to [0nnn]: [errmsg]
  
  After having failed to remove a file, C<remove_tree> was also unable
  to restore the permissions on the file to a possibly less permissive
  setting. (Permissions given in octal).
  
  =item unable to map [owner] to a uid, ownership not changed");
  
  C<make_path> was instructed to give the ownership of created
  directories to the symbolic name [owner], but C<getpwnam> did
  not return the corresponding numeric uid. The directory will
  be created, but ownership will not be changed.
  
  =item unable to map [group] to a gid, group ownership not changed
  
  C<make_path> was instructed to give the group ownership of created
  directories to the symbolic name [group], but C<getgrnam> did
  not return the corresponding numeric gid. The directory will
  be created, but group ownership will not be changed.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<File::Remove>
  
  Allows files and directories to be moved to the Trashcan/Recycle
  Bin (where they may later be restored if necessary) if the operating
  system supports such functionality. This feature may one day be
  made available directly in C<File::Path>.
  
  =item *
  
  L<File::Find::Rule>
  
  When removing directory trees, if you want to examine each file to
  decide whether to delete it (and possibly leaving large swathes
  alone), F<File::Find::Rule> offers a convenient and flexible approach
  to examining directory trees.
  
  =back
  
  =head1 BUGS AND LIMITATIONS
  
  The following describes F<File::Path> limitations and how to report bugs.
  
  =head2 MULTITHREADED APPLICATIONS
  
  F<File::Path> C<rmtree> and C<remove_tree> will not work with
  multithreaded applications due to its use of C<chdir>.  At this time,
  no warning or error is generated in this situation.  You will
  certainly encounter unexpected results.
  
  The implementation that surfaces this limitation will not be changed. See the
  F<File::Path::Tiny> module for functionality similar to F<File::Path> but which does
  not C<chdir>.
  
  =head2 NFS Mount Points
  
  F<File::Path> is not responsible for triggering the automounts, mirror mounts,
  and the contents of network mounted filesystems.  If your NFS implementation
  requires an action to be performed on the filesystem in order for
  F<File::Path> to perform operations, it is strongly suggested you assure
  filesystem availability by reading the root of the mounted filesystem.
  
  =head2 REPORTING BUGS
  
  Please report all bugs on the RT queue, either via the web interface:
  
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
  
  or by email:
  
      bug-File-Path@rt.cpan.org
  
  In either case, please B<attach> patches to the bug report rather than
  including them inline in the web post or the body of the email.
  
  You can also send pull requests to the Github repository:
  
  L<https://github.com/rpcme/File-Path>
  
  =head1 ACKNOWLEDGEMENTS
  
  Paul Szabo identified the race condition originally, and Brendan
  O'Dea wrote an implementation for Debian that addressed the problem.
  That code was used as a basis for the current code. Their efforts
  are greatly appreciated.
  
  Gisle Aas made a number of improvements to the documentation for
  2.07 and his advice and assistance is also greatly appreciated.
  
  =head1 AUTHORS
  
  Prior authors and maintainers: Tim Bunce, Charles Bailey, and
  David Landgren <F<david@landgren.net>>.
  
  Current maintainers are Richard Elberger <F<riche@cpan.org>> and
  James (Jim) Keenan <F<jkeenan@cpan.org>>.
  
  =head1 CONTRIBUTORS
  
  Contributors to File::Path, in alphabetical order by first name.
  
  =over 1
  
  =item <F<bulkdd@cpan.org>>
  
  =item Charlie Gonzalez <F<itcharlie@cpan.org>>
  
  =item Craig A. Berry <F<craigberry@mac.com>>
  
  =item James E Keenan <F<jkeenan@cpan.org>>
  
  =item John Lightsey <F<john@perlsec.org>>
  
  =item Nigel Horne <F<njh@bandsman.co.uk>>
  
  =item Richard Elberger <F<riche@cpan.org>>
  
  =item Ryan Yee <F<ryee@cpan.org>>
  
  =item Skye Shaw <F<shaw@cpan.org>>
  
  =item Tom Lutz <F<tommylutz@gmail.com>>
  
  =item Will Sheppard <F<willsheppard@github>>
  
  =back
  
  =head1 COPYRIGHT
  
  This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren,
  James Keenan and Richard Elberger 1995-2017. All rights reserved.
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
FILE_PATH

$fatpacked{"File/Temp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_TEMP';
  package File::Temp;
  # ABSTRACT: return name and handle of a temporary file safely
  our $VERSION = '0.2304'; # VERSION
  
  
  # Toolchain targets v5.8.1, but we'll try to support back to v5.6 anyway.
  # It might be possible to make this v5.5, but many v5.6isms are creeping
  # into the code and tests.
  use 5.006;
  use strict;
  use Carp;
  use File::Spec 0.8;
  use Cwd ();
  use File::Path 2.06 qw/ rmtree /;
  use Fcntl 1.03;
  use IO::Seekable;               # For SEEK_*
  use Errno;
  use Scalar::Util 'refaddr';
  require VMS::Stdio if $^O eq 'VMS';
  
  # pre-emptively load Carp::Heavy. If we don't when we run out of file
  # handles and attempt to call croak() we get an error message telling
  # us that Carp::Heavy won't load rather than an error telling us we
  # have run out of file handles. We either preload croak() or we
  # switch the calls to croak from _gettemp() to use die.
  eval { require Carp::Heavy; };
  
  # Need the Symbol package if we are running older perl
  require Symbol if $] < 5.006;
  
  ### For the OO interface
  use parent 0.221 qw/ IO::Handle IO::Seekable /;
  use overload '""' => "STRINGIFY", '0+' => "NUMIFY",
    fallback => 1;
  
  # use 'our' on v5.6.0
  use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
  
  $DEBUG = 0;
  $KEEP_ALL = 0;
  
  # We are exporting functions
  
  use Exporter 5.57 'import';   # 5.57 lets us import 'import'
  
  # Export list - to allow fine tuning of export table
  
  @EXPORT_OK = qw{
                   tempfile
                   tempdir
                   tmpnam
                   tmpfile
                   mktemp
                   mkstemp
                   mkstemps
                   mkdtemp
                   unlink0
                   cleanup
                   SEEK_SET
                   SEEK_CUR
                   SEEK_END
               };
  
  # Groups of functions for export
  
  %EXPORT_TAGS = (
                  'POSIX' => [qw/ tmpnam tmpfile /],
                  'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
                  'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
                 );
  
  # add contents of these tags to @EXPORT
  Exporter::export_tags('POSIX','mktemp','seekable');
  
  # This is a list of characters that can be used in random filenames
  
  my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
                   a b c d e f g h i j k l m n o p q r s t u v w x y z
                   0 1 2 3 4 5 6 7 8 9 _
                 /);
  
  # Maximum number of tries to make a temp file before failing
  
  use constant MAX_TRIES => 1000;
  
  # Minimum number of X characters that should be in a template
  use constant MINX => 4;
  
  # Default template when no template supplied
  
  use constant TEMPXXX => 'X' x 10;
  
  # Constants for the security level
  
  use constant STANDARD => 0;
  use constant MEDIUM   => 1;
  use constant HIGH     => 2;
  
  # OPENFLAGS. If we defined the flag to use with Sysopen here this gives
  # us an optimisation when many temporary files are requested
  
  my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
  my $LOCKFLAG;
  
  unless ($^O eq 'MacOS') {
    for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
      my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
      no strict 'refs';
      $OPENFLAGS |= $bit if eval {
        # Make sure that redefined die handlers do not cause problems
        # e.g. CGI::Carp
        local $SIG{__DIE__} = sub {};
        local $SIG{__WARN__} = sub {};
        $bit = &$func();
        1;
      };
    }
    # Special case O_EXLOCK
    $LOCKFLAG = eval {
      local $SIG{__DIE__} = sub {};
      local $SIG{__WARN__} = sub {};
      &Fcntl::O_EXLOCK();
    };
  }
  
  # On some systems the O_TEMPORARY flag can be used to tell the OS
  # to automatically remove the file when it is closed. This is fine
  # in most cases but not if tempfile is called with UNLINK=>0 and
  # the filename is requested -- in the case where the filename is to
  # be passed to another routine. This happens on windows. We overcome
  # this by using a second open flags variable
  
  my $OPENTEMPFLAGS = $OPENFLAGS;
  unless ($^O eq 'MacOS') {
    for my $oflag (qw/ TEMPORARY /) {
      my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
      local($@);
      no strict 'refs';
      $OPENTEMPFLAGS |= $bit if eval {
        # Make sure that redefined die handlers do not cause problems
        # e.g. CGI::Carp
        local $SIG{__DIE__} = sub {};
        local $SIG{__WARN__} = sub {};
        $bit = &$func();
        1;
      };
    }
  }
  
  # Private hash tracking which files have been created by each process id via the OO interface
  my %FILES_CREATED_BY_OBJECT;
  
  # INTERNAL ROUTINES - not to be used outside of package
  
  # Generic routine for getting a temporary filename
  # modelled on OpenBSD _gettemp() in mktemp.c
  
  # The template must contain X's that are to be replaced
  # with the random values
  
  #  Arguments:
  
  #  TEMPLATE   - string containing the XXXXX's that is converted
  #           to a random filename and opened if required
  
  # Optionally, a hash can also be supplied containing specific options
  #   "open" => if true open the temp file, else just return the name
  #             default is 0
  #   "mkdir"=> if true, we are creating a temp directory rather than tempfile
  #             default is 0
  #   "suffixlen" => number of characters at end of PATH to be ignored.
  #                  default is 0.
  #   "unlink_on_close" => indicates that, if possible,  the OS should remove
  #                        the file as soon as it is closed. Usually indicates
  #                        use of the O_TEMPORARY flag to sysopen.
  #                        Usually irrelevant on unix
  #   "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
  
  # Optionally a reference to a scalar can be passed into the function
  # On error this will be used to store the reason for the error
  #   "ErrStr"  => \$errstr
  
  # "open" and "mkdir" can not both be true
  # "unlink_on_close" is not used when "mkdir" is true.
  
  # The default options are equivalent to mktemp().
  
  # Returns:
  #   filehandle - open file handle (if called with doopen=1, else undef)
  #   temp name  - name of the temp file or directory
  
  # For example:
  #   ($fh, $name) = _gettemp($template, "open" => 1);
  
  # for the current version, failures are associated with
  # stored in an error string and returned to give the reason whilst debugging
  # This routine is not called by any external function
  sub _gettemp {
  
    croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
      unless scalar(@_) >= 1;
  
    # the internal error string - expect it to be overridden
    # Need this in case the caller decides not to supply us a value
    # need an anonymous scalar
    my $tempErrStr;
  
    # Default options
    my %options = (
                   "open" => 0,
                   "mkdir" => 0,
                   "suffixlen" => 0,
                   "unlink_on_close" => 0,
                   "use_exlock" => 1,
                   "ErrStr" => \$tempErrStr,
                  );
  
    # Read the template
    my $template = shift;
    if (ref($template)) {
      # Use a warning here since we have not yet merged ErrStr
      carp "File::Temp::_gettemp: template must not be a reference";
      return ();
    }
  
    # Check that the number of entries on stack are even
    if (scalar(@_) % 2 != 0) {
      # Use a warning here since we have not yet merged ErrStr
      carp "File::Temp::_gettemp: Must have even number of options";
      return ();
    }
  
    # Read the options and merge with defaults
    %options = (%options, @_)  if @_;
  
    # Make sure the error string is set to undef
    ${$options{ErrStr}} = undef;
  
    # Can not open the file and make a directory in a single call
    if ($options{"open"} && $options{"mkdir"}) {
      ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
      return ();
    }
  
    # Find the start of the end of the  Xs (position of last X)
    # Substr starts from 0
    my $start = length($template) - 1 - $options{"suffixlen"};
  
    # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
    # (taking suffixlen into account). Any fewer is insecure.
  
    # Do it using substr - no reason to use a pattern match since
    # we know where we are looking and what we are looking for
  
    if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
      ${$options{ErrStr}} = "The template must end with at least ".
        MINX . " 'X' characters\n";
      return ();
    }
  
    # Replace all the X at the end of the substring with a
    # random character or just all the XX at the end of a full string.
    # Do it as an if, since the suffix adjusts which section to replace
    # and suffixlen=0 returns nothing if used in the substr directly
    # and generate a full path from the template
  
    my $path = _replace_XX($template, $options{"suffixlen"});
  
  
    # Split the path into constituent parts - eventually we need to check
    # whether the directory exists
    # We need to know whether we are making a temp directory
    # or a tempfile
  
    my ($volume, $directories, $file);
    my $parent;                   # parent directory
    if ($options{"mkdir"}) {
      # There is no filename at the end
      ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
  
      # The parent is then $directories without the last directory
      # Split the directory and put it back together again
      my @dirs = File::Spec->splitdir($directories);
  
      # If @dirs only has one entry (i.e. the directory template) that means
      # we are in the current directory
      if ($#dirs == 0) {
        $parent = File::Spec->curdir;
      } else {
  
        if ($^O eq 'VMS') {     # need volume to avoid relative dir spec
          $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
          $parent = 'sys$disk:[]' if $parent eq '';
        } else {
  
          # Put it back together without the last one
          $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
  
          # ...and attach the volume (no filename)
          $parent = File::Spec->catpath($volume, $parent, '');
        }
  
      }
  
    } else {
  
      # Get rid of the last filename (use File::Basename for this?)
      ($volume, $directories, $file) = File::Spec->splitpath( $path );
  
      # Join up without the file part
      $parent = File::Spec->catpath($volume,$directories,'');
  
      # If $parent is empty replace with curdir
      $parent = File::Spec->curdir
        unless $directories ne '';
  
    }
  
    # Check that the parent directories exist
    # Do this even for the case where we are simply returning a name
    # not a file -- no point returning a name that includes a directory
    # that does not exist or is not writable
  
    unless (-e $parent) {
      ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
      return ();
    }
    unless (-d $parent) {
      ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
      return ();
    }
  
    # Check the stickiness of the directory and chown giveaway if required
    # If the directory is world writable the sticky bit
    # must be set
  
    if (File::Temp->safe_level == MEDIUM) {
      my $safeerr;
      unless (_is_safe($parent,\$safeerr)) {
        ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
        return ();
      }
    } elsif (File::Temp->safe_level == HIGH) {
      my $safeerr;
      unless (_is_verysafe($parent, \$safeerr)) {
        ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
        return ();
      }
    }
  
  
    # Now try MAX_TRIES time to open the file
    for (my $i = 0; $i < MAX_TRIES; $i++) {
  
      # Try to open the file if requested
      if ($options{"open"}) {
        my $fh;
  
        # If we are running before perl5.6.0 we can not auto-vivify
        if ($] < 5.006) {
          $fh = &Symbol::gensym;
        }
  
        # Try to make sure this will be marked close-on-exec
        # XXX: Win32 doesn't respect this, nor the proper fcntl,
        #      but may have O_NOINHERIT. This may or may not be in Fcntl.
        local $^F = 2;
  
        # Attempt to open the file
        my $open_success = undef;
        if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
          # make it auto delete on close by setting FAB$V_DLT bit
          $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
          $open_success = $fh;
        } else {
          my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
                        $OPENTEMPFLAGS :
                        $OPENFLAGS );
          $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
          $open_success = sysopen($fh, $path, $flags, 0600);
        }
        if ( $open_success ) {
  
          # in case of odd umask force rw
          chmod(0600, $path);
  
          # Opened successfully - return file handle and name
          return ($fh, $path);
  
        } else {
  
          # Error opening file - abort with error
          # if the reason was anything but EEXIST
          unless ($!{EEXIST}) {
            ${$options{ErrStr}} = "Could not create temp file $path: $!";
            return ();
          }
  
          # Loop round for another try
  
        }
      } elsif ($options{"mkdir"}) {
  
        # Open the temp directory
        if (mkdir( $path, 0700)) {
          # in case of odd umask
          chmod(0700, $path);
  
          return undef, $path;
        } else {
  
          # Abort with error if the reason for failure was anything
          # except EEXIST
          unless ($!{EEXIST}) {
            ${$options{ErrStr}} = "Could not create directory $path: $!";
            return ();
          }
  
          # Loop round for another try
  
        }
  
      } else {
  
        # Return true if the file can not be found
        # Directory has been checked previously
  
        return (undef, $path) unless -e $path;
  
        # Try again until MAX_TRIES
  
      }
  
      # Did not successfully open the tempfile/dir
      # so try again with a different set of random letters
      # No point in trying to increment unless we have only
      # 1 X say and the randomness could come up with the same
      # file MAX_TRIES in a row.
  
      # Store current attempt - in principal this implies that the
      # 3rd time around the open attempt that the first temp file
      # name could be generated again. Probably should store each
      # attempt and make sure that none are repeated
  
      my $original = $path;
      my $counter = 0;            # Stop infinite loop
      my $MAX_GUESS = 50;
  
      do {
  
        # Generate new name from original template
        $path = _replace_XX($template, $options{"suffixlen"});
  
        $counter++;
  
      } until ($path ne $original || $counter > $MAX_GUESS);
  
      # Check for out of control looping
      if ($counter > $MAX_GUESS) {
        ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
        return ();
      }
  
    }
  
    # If we get here, we have run out of tries
    ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
      . MAX_TRIES . ") to open temp file/dir";
  
    return ();
  
  }
  
  # Internal routine to replace the XXXX... with random characters
  # This has to be done by _gettemp() every time it fails to
  # open a temp file/dir
  
  # Arguments:  $template (the template with XXX),
  #             $ignore   (number of characters at end to ignore)
  
  # Returns:    modified template
  
  sub _replace_XX {
  
    croak 'Usage: _replace_XX($template, $ignore)'
      unless scalar(@_) == 2;
  
    my ($path, $ignore) = @_;
  
    # Do it as an if, since the suffix adjusts which section to replace
    # and suffixlen=0 returns nothing if used in the substr directly
    # Alternatively, could simply set $ignore to length($path)-1
    # Don't want to always use substr when not required though.
    my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
  
    if ($ignore) {
      substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
    } else {
      $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
    }
    return $path;
  }
  
  # Internal routine to force a temp file to be writable after
  # it is created so that we can unlink it. Windows seems to occasionally
  # force a file to be readonly when written to certain temp locations
  sub _force_writable {
    my $file = shift;
    chmod 0600, $file;
  }
  
  
  # internal routine to check to see if the directory is safe
  # First checks to see if the directory is not owned by the
  # current user or root. Then checks to see if anyone else
  # can write to the directory and if so, checks to see if
  # it has the sticky bit set
  
  # Will not work on systems that do not support sticky bit
  
  #Args:  directory path to check
  #       Optionally: reference to scalar to contain error message
  # Returns true if the path is safe and false otherwise.
  # Returns undef if can not even run stat() on the path
  
  # This routine based on version written by Tom Christiansen
  
  # Presumably, by the time we actually attempt to create the
  # file or directory in this directory, it may not be safe
  # anymore... Have to run _is_safe directly after the open.
  
  sub _is_safe {
  
    my $path = shift;
    my $err_ref = shift;
  
    # Stat path
    my @info = stat($path);
    unless (scalar(@info)) {
      $$err_ref = "stat(path) returned no values";
      return 0;
    }
    ;
    return 1 if $^O eq 'VMS';     # owner delete control at file level
  
    # Check to see whether owner is neither superuser (or a system uid) nor me
    # Use the effective uid from the $> variable
    # UID is in [4]
    if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
  
      Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
                  File::Temp->top_system_uid());
  
      $$err_ref = "Directory owned neither by root nor the current user"
        if ref($err_ref);
      return 0;
    }
  
    # check whether group or other can write file
    # use 066 to detect either reading or writing
    # use 022 to check writability
    # Do it with S_IWOTH and S_IWGRP for portability (maybe)
    # mode is in info[2]
    if (($info[2] & &Fcntl::S_IWGRP) ||  # Is group writable?
        ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
      # Must be a directory
      unless (-d $path) {
        $$err_ref = "Path ($path) is not a directory"
          if ref($err_ref);
        return 0;
      }
      # Must have sticky bit set
      unless (-k $path) {
        $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
          if ref($err_ref);
        return 0;
      }
    }
  
    return 1;
  }
  
  # Internal routine to check whether a directory is safe
  # for temp files. Safer than _is_safe since it checks for
  # the possibility of chown giveaway and if that is a possibility
  # checks each directory in the path to see if it is safe (with _is_safe)
  
  # If _PC_CHOWN_RESTRICTED is not set, does the full test of each
  # directory anyway.
  
  # Takes optional second arg as scalar ref to error reason
  
  sub _is_verysafe {
  
    # Need POSIX - but only want to bother if really necessary due to overhead
    require POSIX;
  
    my $path = shift;
    print "_is_verysafe testing $path\n" if $DEBUG;
    return 1 if $^O eq 'VMS';     # owner delete control at file level
  
    my $err_ref = shift;
  
    # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
    # and If it is not there do the extensive test
    local($@);
    my $chown_restricted;
    $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
      if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
  
    # If chown_resticted is set to some value we should test it
    if (defined $chown_restricted) {
  
      # Return if the current directory is safe
      return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
  
    }
  
    # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
    # was not available or the symbol was there but chown giveaway
    # is allowed. Either way, we now have to test the entire tree for
    # safety.
  
    # Convert path to an absolute directory if required
    unless (File::Spec->file_name_is_absolute($path)) {
      $path = File::Spec->rel2abs($path);
    }
  
    # Split directory into components - assume no file
    my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
  
    # Slightly less efficient than having a function in File::Spec
    # to chop off the end of a directory or even a function that
    # can handle ../ in a directory tree
    # Sometimes splitdir() returns a blank at the end
    # so we will probably check the bottom directory twice in some cases
    my @dirs = File::Spec->splitdir($directories);
  
    # Concatenate one less directory each time around
    foreach my $pos (0.. $#dirs) {
      # Get a directory name
      my $dir = File::Spec->catpath($volume,
                                    File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
                                    ''
                                   );
  
      print "TESTING DIR $dir\n" if $DEBUG;
  
      # Check the directory
      return 0 unless _is_safe($dir,$err_ref);
  
    }
  
    return 1;
  }
  
  
  
  # internal routine to determine whether unlink works on this
  # platform for files that are currently open.
  # Returns true if we can, false otherwise.
  
  # Currently WinNT, OS/2 and VMS can not unlink an opened file
  # On VMS this is because the O_EXCL flag is used to open the
  # temporary file. Currently I do not know enough about the issues
  # on VMS to decide whether O_EXCL is a requirement.
  
  sub _can_unlink_opened_file {
  
    if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) {
      return 0;
    } else {
      return 1;
    }
  
  }
  
  # internal routine to decide which security levels are allowed
  # see safe_level() for more information on this
  
  # Controls whether the supplied security level is allowed
  
  #   $cando = _can_do_level( $level )
  
  sub _can_do_level {
  
    # Get security level
    my $level = shift;
  
    # Always have to be able to do STANDARD
    return 1 if $level == STANDARD;
  
    # Currently, the systems that can do HIGH or MEDIUM are identical
    if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
      return 0;
    } else {
      return 1;
    }
  
  }
  
  # This routine sets up a deferred unlinking of a specified
  # filename and filehandle. It is used in the following cases:
  #  - Called by unlink0 if an opened file can not be unlinked
  #  - Called by tempfile() if files are to be removed on shutdown
  #  - Called by tempdir() if directories are to be removed on shutdown
  
  # Arguments:
  #   _deferred_unlink( $fh, $fname, $isdir );
  #
  #   - filehandle (so that it can be explicitly closed if open
  #   - filename   (the thing we want to remove)
  #   - isdir      (flag to indicate that we are being given a directory)
  #                 [and hence no filehandle]
  
  # Status is not referred to since all the magic is done with an END block
  
  {
    # Will set up two lexical variables to contain all the files to be
    # removed. One array for files, another for directories They will
    # only exist in this block.
  
    #  This means we only have to set up a single END block to remove
    #  all files. 
  
    # in order to prevent child processes inadvertently deleting the parent
    # temp files we use a hash to store the temp files and directories
    # created by a particular process id.
  
    # %files_to_unlink contains values that are references to an array of
    # array references containing the filehandle and filename associated with
    # the temp file.
    my (%files_to_unlink, %dirs_to_unlink);
  
    # Set up an end block to use these arrays
    END {
      local($., $@, $!, $^E, $?);
      cleanup(at_exit => 1);
    }
  
    # Cleanup function. Always triggered on END (with at_exit => 1) but
    # can be invoked manually.
    sub cleanup {
      my %h = @_;
      my $at_exit = delete $h{at_exit};
      $at_exit = 0 if not defined $at_exit;
      { my @k = sort keys %h; die "unrecognized parameters: @k" if @k }
  
      if (!$KEEP_ALL) {
        # Files
        my @files = (exists $files_to_unlink{$$} ?
                     @{ $files_to_unlink{$$} } : () );
        foreach my $file (@files) {
          # close the filehandle without checking its state
          # in order to make real sure that this is closed
          # if its already closed then I don't care about the answer
          # probably a better way to do this
          close($file->[0]);      # file handle is [0]
  
          if (-f $file->[1]) {       # file name is [1]
            _force_writable( $file->[1] ); # for windows
            unlink $file->[1] or warn "Error removing ".$file->[1];
          }
        }
        # Dirs
        my @dirs = (exists $dirs_to_unlink{$$} ?
                    @{ $dirs_to_unlink{$$} } : () );
        my ($cwd, $cwd_to_remove);
        foreach my $dir (@dirs) {
          if (-d $dir) {
            # Some versions of rmtree will abort if you attempt to remove
            # the directory you are sitting in. For automatic cleanup
            # at program exit, we avoid this by chdir()ing out of the way
            # first. If not at program exit, it's best not to mess with the
            # current directory, so just let it fail with a warning.
            if ($at_exit) {
              $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd;
              my $abs = Cwd::abs_path($dir);
              if ($abs eq $cwd) {
                $cwd_to_remove = $dir;
                next;
              }
            }
            eval { rmtree($dir, $DEBUG, 0); };
            warn $@ if ($@ && $^W);
          }
        }
  
        if (defined $cwd_to_remove) {
          # We do need to clean up the current directory, and everything
          # else is done, so get out of there and remove it.
          chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!";
          my $updir = File::Spec->updir;
          chdir $updir or die "cannot chdir to $updir: $!";
          eval { rmtree($cwd_to_remove, $DEBUG, 0); };
          warn $@ if ($@ && $^W);
        }
  
        # clear the arrays
        @{ $files_to_unlink{$$} } = ()
          if exists $files_to_unlink{$$};
        @{ $dirs_to_unlink{$$} } = ()
          if exists $dirs_to_unlink{$$};
      }
    }
  
  
    # This is the sub called to register a file for deferred unlinking
    # This could simply store the input parameters and defer everything
    # until the END block. For now we do a bit of checking at this
    # point in order to make sure that (1) we have a file/dir to delete
    # and (2) we have been called with the correct arguments.
    sub _deferred_unlink {
  
      croak 'Usage:  _deferred_unlink($fh, $fname, $isdir)'
        unless scalar(@_) == 3;
  
      my ($fh, $fname, $isdir) = @_;
  
      warn "Setting up deferred removal of $fname\n"
        if $DEBUG;
  
      # make sure we save the absolute path for later cleanup
      # OK to untaint because we only ever use this internally
      # as a file path, never interpolating into the shell
      $fname = Cwd::abs_path($fname);
      ($fname) = $fname =~ /^(.*)$/;
  
      # If we have a directory, check that it is a directory
      if ($isdir) {
  
        if (-d $fname) {
  
          # Directory exists so store it
          # first on VMS turn []foo into [.foo] for rmtree
          $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
          $dirs_to_unlink{$$} = [] 
            unless exists $dirs_to_unlink{$$};
          push (@{ $dirs_to_unlink{$$} }, $fname);
  
        } else {
          carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
        }
  
      } else {
  
        if (-f $fname) {
  
          # file exists so store handle and name for later removal
          $files_to_unlink{$$} = []
            unless exists $files_to_unlink{$$};
          push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
  
        } else {
          carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
        }
  
      }
  
    }
  
  
  }
  
  # normalize argument keys to upper case and do consistent handling
  # of leading template vs TEMPLATE
  sub _parse_args {
    my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' );
    my %args = @_;
    %args = map { uc($_), $args{$_} } keys %args;
  
    # template (store it in an array so that it will
    # disappear from the arg list of tempfile)
    my @template = (
      exists $args{TEMPLATE}  ? $args{TEMPLATE} :
      $leading_template       ? $leading_template : ()
    );
    delete $args{TEMPLATE};
  
    return( \@template, \%args );
  }
  
  
  sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
  
    my ($maybe_template, $args) = _parse_args(@_);
  
    # see if they are unlinking (defaulting to yes)
    my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 );
    delete $args->{UNLINK};
  
    # Protect OPEN
    delete $args->{OPEN};
  
    # Open the file and retain file handle and file name
    my ($fh, $path) = tempfile( @$maybe_template, %$args );
  
    print "Tmp: $fh - $path\n" if $DEBUG;
  
    # Store the filename in the scalar slot
    ${*$fh} = $path;
  
    # Cache the filename by pid so that the destructor can decide whether to remove it
    $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
  
    # Store unlink information in hash slot (plus other constructor info)
    %{*$fh} = %$args;
  
    # create the object
    bless $fh, $class;
  
    # final method-based configuration
    $fh->unlink_on_destroy( $unlink );
  
    return $fh;
  }
  
  
  sub newdir {
    my $self = shift;
  
    my ($maybe_template, $args) = _parse_args(@_);
  
    # handle CLEANUP without passing CLEANUP to tempdir
    my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 );
    delete $args->{CLEANUP};
  
    my $tempdir = tempdir( @$maybe_template, %$args);
  
    # get a safe absolute path for cleanup, just like
    # happens in _deferred_unlink
    my $real_dir = Cwd::abs_path( $tempdir );
    ($real_dir) = $real_dir =~ /^(.*)$/;
  
    return bless { DIRNAME => $tempdir,
                   REALNAME => $real_dir,
                   CLEANUP => $cleanup,
                   LAUNCHPID => $$,
                 }, "File::Temp::Dir";
  }
  
  
  sub filename {
    my $self = shift;
    return ${*$self};
  }
  
  sub STRINGIFY {
    my $self = shift;
    return $self->filename;
  }
  
  # For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because
  # refaddr() demands one parameter only, whereas overload.pm calls with three
  # even for unary operations like '0+'.
  sub NUMIFY {
    return refaddr($_[0]);
  }
  
  
  sub unlink_on_destroy {
    my $self = shift;
    if (@_) {
      ${*$self}{UNLINK} = shift;
    }
    return ${*$self}{UNLINK};
  }
  
  
  sub DESTROY {
    local($., $@, $!, $^E, $?);
    my $self = shift;
  
    # Make sure we always remove the file from the global hash
    # on destruction. This prevents the hash from growing uncontrollably
    # and post-destruction there is no reason to know about the file.
    my $file = $self->filename;
    my $was_created_by_proc;
    if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
      $was_created_by_proc = 1;
      delete $FILES_CREATED_BY_OBJECT{$$}{$file};
    }
  
    if (${*$self}{UNLINK} && !$KEEP_ALL) {
      print "# --------->   Unlinking $self\n" if $DEBUG;
  
      # only delete if this process created it
      return unless $was_created_by_proc;
  
      # The unlink1 may fail if the file has been closed
      # by the caller. This leaves us with the decision
      # of whether to refuse to remove the file or simply
      # do an unlink without test. Seems to be silly
      # to do this when we are trying to be careful
      # about security
      _force_writable( $file ); # for windows
      unlink1( $self, $file )
        or unlink($file);
    }
  }
  
  
  sub tempfile {
    if ( @_ && $_[0] eq 'File::Temp' ) {
        croak "'tempfile' can't be called as a method";
    }
    # Can not check for argument count since we can have any
    # number of args
  
    # Default options
    my %options = (
                   "DIR"    => undef, # Directory prefix
                   "SUFFIX" => '',    # Template suffix
                   "UNLINK" => 0,     # Do not unlink file on exit
                   "OPEN"   => 1,     # Open file
                   "TMPDIR" => 0, # Place tempfile in tempdir if template specified
                   "EXLOCK" => 1, # Open file with O_EXLOCK
                  );
  
    # Check to see whether we have an odd or even number of arguments
    my ($maybe_template, $args) = _parse_args(@_);
    my $template = @$maybe_template ? $maybe_template->[0] : undef;
  
    # Read the options and merge with defaults
    %options = (%options, %$args);
  
    # First decision is whether or not to open the file
    if (! $options{"OPEN"}) {
  
      warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
        if $^W;
  
    }
  
    if ($options{"DIR"} and $^O eq 'VMS') {
  
      # on VMS turn []foo into [.foo] for concatenation
      $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
    }
  
    # Construct the template
  
    # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
    # functions or simply constructing a template and using _gettemp()
    # explicitly. Go for the latter
  
    # First generate a template if not defined and prefix the directory
    # If no template must prefix the temp directory
    if (defined $template) {
      # End up with current directory if neither DIR not TMPDIR are set
      if ($options{"DIR"}) {
  
        $template = File::Spec->catfile($options{"DIR"}, $template);
  
      } elsif ($options{TMPDIR}) {
  
        $template = File::Spec->catfile(File::Spec->tmpdir, $template );
  
      }
  
    } else {
  
      if ($options{"DIR"}) {
  
        $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
  
      } else {
  
        $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
  
      }
  
    }
  
    # Now add a suffix
    $template .= $options{"SUFFIX"};
  
    # Determine whether we should tell _gettemp to unlink the file
    # On unix this is irrelevant and can be worked out after the file is
    # opened (simply by unlinking the open filehandle). On Windows or VMS
    # we have to indicate temporary-ness when we open the file. In general
    # we only want a true temporary file if we are returning just the
    # filehandle - if the user wants the filename they probably do not
    # want the file to disappear as soon as they close it (which may be
    # important if they want a child process to use the file)
    # For this reason, tie unlink_on_close to the return context regardless
    # of OS.
    my $unlink_on_close = ( wantarray ? 0 : 1);
  
    # Create the file
    my ($fh, $path, $errstr);
    croak "Error in tempfile() using template $template: $errstr"
      unless (($fh, $path) = _gettemp($template,
                                      "open" => $options{'OPEN'},
                                      "mkdir"=> 0 ,
                                      "unlink_on_close" => $unlink_on_close,
                                      "suffixlen" => length($options{'SUFFIX'}),
                                      "ErrStr" => \$errstr,
                                      "use_exlock" => $options{EXLOCK},
                                     ) );
  
    # Set up an exit handler that can do whatever is right for the
    # system. This removes files at exit when requested explicitly or when
    # system is asked to unlink_on_close but is unable to do so because
    # of OS limitations.
    # The latter should be achieved by using a tied filehandle.
    # Do not check return status since this is all done with END blocks.
    _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
  
    # Return
    if (wantarray()) {
  
      if ($options{'OPEN'}) {
        return ($fh, $path);
      } else {
        return (undef, $path);
      }
  
    } else {
  
      # Unlink the file. It is up to unlink0 to decide what to do with
      # this (whether to unlink now or to defer until later)
      unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
  
      # Return just the filehandle.
      return $fh;
    }
  
  
  }
  
  
  # '
  
  sub tempdir  {
    if ( @_ && $_[0] eq 'File::Temp' ) {
        croak "'tempdir' can't be called as a method";
    }
  
    # Can not check for argument count since we can have any
    # number of args
  
    # Default options
    my %options = (
                   "CLEANUP"    => 0, # Remove directory on exit
                   "DIR"        => '', # Root directory
                   "TMPDIR"     => 0,  # Use tempdir with template
                  );
  
    # Check to see whether we have an odd or even number of arguments
    my ($maybe_template, $args) = _parse_args(@_);
    my $template = @$maybe_template ? $maybe_template->[0] : undef;
  
    # Read the options and merge with defaults
    %options = (%options, %$args);
  
    # Modify or generate the template
  
    # Deal with the DIR and TMPDIR options
    if (defined $template) {
  
      # Need to strip directory path if using DIR or TMPDIR
      if ($options{'TMPDIR'} || $options{'DIR'}) {
  
        # Strip parent directory from the filename
        #
        # There is no filename at the end
        $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
        my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
  
        # Last directory is then our template
        $template = (File::Spec->splitdir($directories))[-1];
  
        # Prepend the supplied directory or temp dir
        if ($options{"DIR"}) {
  
          $template = File::Spec->catdir($options{"DIR"}, $template);
  
        } elsif ($options{TMPDIR}) {
  
          # Prepend tmpdir
          $template = File::Spec->catdir(File::Spec->tmpdir, $template);
  
        }
  
      }
  
    } else {
  
      if ($options{"DIR"}) {
  
        $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
  
      } else {
  
        $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
  
      }
  
    }
  
    # Create the directory
    my $tempdir;
    my $suffixlen = 0;
    if ($^O eq 'VMS') {           # dir names can end in delimiters
      $template =~ m/([\.\]:>]+)$/;
      $suffixlen = length($1);
    }
    if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
      # dir name has a trailing ':'
      ++$suffixlen;
    }
  
    my $errstr;
    croak "Error in tempdir() using $template: $errstr"
      unless ((undef, $tempdir) = _gettemp($template,
                                           "open" => 0,
                                           "mkdir"=> 1 ,
                                           "suffixlen" => $suffixlen,
                                           "ErrStr" => \$errstr,
                                          ) );
  
    # Install exit handler; must be dynamic to get lexical
    if ( $options{'CLEANUP'} && -d $tempdir) {
      _deferred_unlink(undef, $tempdir, 1);
    }
  
    # Return the dir name
    return $tempdir;
  
  }
  
  
  
  
  sub mkstemp {
  
    croak "Usage: mkstemp(template)"
      if scalar(@_) != 1;
  
    my $template = shift;
  
    my ($fh, $path, $errstr);
    croak "Error in mkstemp using $template: $errstr"
      unless (($fh, $path) = _gettemp($template,
                                      "open" => 1,
                                      "mkdir"=> 0 ,
                                      "suffixlen" => 0,
                                      "ErrStr" => \$errstr,
                                     ) );
  
    if (wantarray()) {
      return ($fh, $path);
    } else {
      return $fh;
    }
  
  }
  
  
  
  sub mkstemps {
  
    croak "Usage: mkstemps(template, suffix)"
      if scalar(@_) != 2;
  
  
    my $template = shift;
    my $suffix   = shift;
  
    $template .= $suffix;
  
    my ($fh, $path, $errstr);
    croak "Error in mkstemps using $template: $errstr"
      unless (($fh, $path) = _gettemp($template,
                                      "open" => 1,
                                      "mkdir"=> 0 ,
                                      "suffixlen" => length($suffix),
                                      "ErrStr" => \$errstr,
                                     ) );
  
    if (wantarray()) {
      return ($fh, $path);
    } else {
      return $fh;
    }
  
  }
  
  
  #' # for emacs
  
  sub mkdtemp {
  
    croak "Usage: mkdtemp(template)"
      if scalar(@_) != 1;
  
    my $template = shift;
    my $suffixlen = 0;
    if ($^O eq 'VMS') {           # dir names can end in delimiters
      $template =~ m/([\.\]:>]+)$/;
      $suffixlen = length($1);
    }
    if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
      # dir name has a trailing ':'
      ++$suffixlen;
    }
    my ($junk, $tmpdir, $errstr);
    croak "Error creating temp directory from template $template\: $errstr"
      unless (($junk, $tmpdir) = _gettemp($template,
                                          "open" => 0,
                                          "mkdir"=> 1 ,
                                          "suffixlen" => $suffixlen,
                                          "ErrStr" => \$errstr,
                                         ) );
  
    return $tmpdir;
  
  }
  
  
  sub mktemp {
  
    croak "Usage: mktemp(template)"
      if scalar(@_) != 1;
  
    my $template = shift;
  
    my ($tmpname, $junk, $errstr);
    croak "Error getting name to temp file from template $template: $errstr"
      unless (($junk, $tmpname) = _gettemp($template,
                                           "open" => 0,
                                           "mkdir"=> 0 ,
                                           "suffixlen" => 0,
                                           "ErrStr" => \$errstr,
                                          ) );
  
    return $tmpname;
  }
  
  
  sub tmpnam {
  
    # Retrieve the temporary directory name
    my $tmpdir = File::Spec->tmpdir;
  
    croak "Error temporary directory is not writable"
      if $tmpdir eq '';
  
    # Use a ten character template and append to tmpdir
    my $template = File::Spec->catfile($tmpdir, TEMPXXX);
  
    if (wantarray() ) {
      return mkstemp($template);
    } else {
      return mktemp($template);
    }
  
  }
  
  
  sub tmpfile {
  
    # Simply call tmpnam() in a list context
    my ($fh, $file) = tmpnam();
  
    # Make sure file is removed when filehandle is closed
    # This will fail on NFS
    unlink0($fh, $file)
      or return undef;
  
    return $fh;
  
  }
  
  
  sub tempnam {
  
    croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
  
    my ($dir, $prefix) = @_;
  
    # Add a string to the prefix
    $prefix .= 'XXXXXXXX';
  
    # Concatenate the directory to the file
    my $template = File::Spec->catfile($dir, $prefix);
  
    return mktemp($template);
  
  }
  
  
  sub unlink0 {
  
    croak 'Usage: unlink0(filehandle, filename)'
      unless scalar(@_) == 2;
  
    # Read args
    my ($fh, $path) = @_;
  
    cmpstat($fh, $path) or return 0;
  
    # attempt remove the file (does not work on some platforms)
    if (_can_unlink_opened_file()) {
  
      # return early (Without unlink) if we have been instructed to retain files.
      return 1 if $KEEP_ALL;
  
      # XXX: do *not* call this on a directory; possible race
      #      resulting in recursive removal
      croak "unlink0: $path has become a directory!" if -d $path;
      unlink($path) or return 0;
  
      # Stat the filehandle
      my @fh = stat $fh;
  
      print "Link count = $fh[3] \n" if $DEBUG;
  
      # Make sure that the link count is zero
      # - Cygwin provides deferred unlinking, however,
      #   on Win9x the link count remains 1
      # On NFS the link count may still be 1 but we can't know that
      # we are on NFS.  Since we can't be sure, we'll defer it
  
      return 1 if $fh[3] == 0 || $^O eq 'cygwin';
    }
    # fall-through if we can't unlink now
    _deferred_unlink($fh, $path, 0);
    return 1;
  }
  
  
  sub cmpstat {
  
    croak 'Usage: cmpstat(filehandle, filename)'
      unless scalar(@_) == 2;
  
    # Read args
    my ($fh, $path) = @_;
  
    warn "Comparing stat\n"
      if $DEBUG;
  
    # Stat the filehandle - which may be closed if someone has manually
    # closed the file. Can not turn off warnings without using $^W
    # unless we upgrade to 5.006 minimum requirement
    my @fh;
    {
      local ($^W) = 0;
      @fh = stat $fh;
    }
    return unless @fh;
  
    if ($fh[3] > 1 && $^W) {
      carp "unlink0: fstat found too many links; SB=@fh" if $^W;
    }
  
    # Stat the path
    my @path = stat $path;
  
    unless (@path) {
      carp "unlink0: $path is gone already" if $^W;
      return;
    }
  
    # this is no longer a file, but may be a directory, or worse
    unless (-f $path) {
      confess "panic: $path is no longer a file: SB=@fh";
    }
  
    # Do comparison of each member of the array
    # On WinNT dev and rdev seem to be different
    # depending on whether it is a file or a handle.
    # Cannot simply compare all members of the stat return
    # Select the ones we can use
    my @okstat = (0..$#fh);       # Use all by default
    if ($^O eq 'MSWin32') {
      @okstat = (1,2,3,4,5,7,8,9,10);
    } elsif ($^O eq 'os2') {
      @okstat = (0, 2..$#fh);
    } elsif ($^O eq 'VMS') {      # device and file ID are sufficient
      @okstat = (0, 1);
    } elsif ($^O eq 'dos') {
      @okstat = (0,2..7,11..$#fh);
    } elsif ($^O eq 'mpeix') {
      @okstat = (0..4,8..10);
    }
  
    # Now compare each entry explicitly by number
    for (@okstat) {
      print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
      # Use eq rather than == since rdev, blksize, and blocks (6, 11,
      # and 12) will be '' on platforms that do not support them.  This
      # is fine since we are only comparing integers.
      unless ($fh[$_] eq $path[$_]) {
        warn "Did not match $_ element of stat\n" if $DEBUG;
        return 0;
      }
    }
  
    return 1;
  }
  
  
  sub unlink1 {
    croak 'Usage: unlink1(filehandle, filename)'
      unless scalar(@_) == 2;
  
    # Read args
    my ($fh, $path) = @_;
  
    cmpstat($fh, $path) or return 0;
  
    # Close the file
    close( $fh ) or return 0;
  
    # Make sure the file is writable (for windows)
    _force_writable( $path );
  
    # return early (without unlink) if we have been instructed to retain files.
    return 1 if $KEEP_ALL;
  
    # remove the file
    return unlink($path);
  }
  
  
  {
    # protect from using the variable itself
    my $LEVEL = STANDARD;
    sub safe_level {
      my $self = shift;
      if (@_) {
        my $level = shift;
        if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
          carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
        } else {
          # Don't allow this on perl 5.005 or earlier
          if ($] < 5.006 && $level != STANDARD) {
            # Cant do MEDIUM or HIGH checks
            croak "Currently requires perl 5.006 or newer to do the safe checks";
          }
          # Check that we are allowed to change level
          # Silently ignore if we can not.
          $LEVEL = $level if _can_do_level($level);
        }
      }
      return $LEVEL;
    }
  }
  
  
  {
    my $TopSystemUID = 10;
    $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
    sub top_system_uid {
      my $self = shift;
      if (@_) {
        my $newuid = shift;
        croak "top_system_uid: UIDs should be numeric"
          unless $newuid =~ /^\d+$/s;
        $TopSystemUID = $newuid;
      }
      return $TopSystemUID;
    }
  }
  
  
  package File::Temp::Dir;
  
  use File::Path qw/ rmtree /;
  use strict;
  use overload '""' => "STRINGIFY",
    '0+' => \&File::Temp::NUMIFY,
    fallback => 1;
  
  # private class specifically to support tempdir objects
  # created by File::Temp->newdir
  
  # ostensibly the same method interface as File::Temp but without
  # inheriting all the IO::Seekable methods and other cruft
  
  # Read-only - returns the name of the temp directory
  
  sub dirname {
    my $self = shift;
    return $self->{DIRNAME};
  }
  
  sub STRINGIFY {
    my $self = shift;
    return $self->dirname;
  }
  
  sub unlink_on_destroy {
    my $self = shift;
    if (@_) {
      $self->{CLEANUP} = shift;
    }
    return $self->{CLEANUP};
  }
  
  sub DESTROY {
    my $self = shift;
    local($., $@, $!, $^E, $?);
    if ($self->unlink_on_destroy && 
        $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
      if (-d $self->{REALNAME}) {
        # Some versions of rmtree will abort if you attempt to remove
        # the directory you are sitting in. We protect that and turn it
        # into a warning. We do this because this occurs during object
        # destruction and so can not be caught by the user.
        eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); };
        warn $@ if ($@ && $^W);
      }
    }
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  File::Temp - return name and handle of a temporary file safely
  
  =head1 VERSION
  
  version 0.2304
  
  =head1 SYNOPSIS
  
    use File::Temp qw/ tempfile tempdir /;
  
    $fh = tempfile();
    ($fh, $filename) = tempfile();
  
    ($fh, $filename) = tempfile( $template, DIR => $dir);
    ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
    ($fh, $filename) = tempfile( $template, TMPDIR => 1 );
  
    binmode( $fh, ":utf8" );
  
    $dir = tempdir( CLEANUP => 1 );
    ($fh, $filename) = tempfile( DIR => $dir );
  
  Object interface:
  
    require File::Temp;
    use File::Temp ();
    use File::Temp qw/ :seekable /;
  
    $fh = File::Temp->new();
    $fname = $fh->filename;
  
    $fh = File::Temp->new(TEMPLATE => $template);
    $fname = $fh->filename;
  
    $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
    print $tmp "Some data\n";
    print "Filename is $tmp\n";
    $tmp->seek( 0, SEEK_END );
  
  The following interfaces are provided for compatibility with
  existing APIs. They should not be used in new code.
  
  MkTemp family:
  
    use File::Temp qw/ :mktemp  /;
  
    ($fh, $file) = mkstemp( "tmpfileXXXXX" );
    ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
  
    $tmpdir = mkdtemp( $template );
  
    $unopened_file = mktemp( $template );
  
  POSIX functions:
  
    use File::Temp qw/ :POSIX /;
  
    $file = tmpnam();
    $fh = tmpfile();
  
    ($fh, $file) = tmpnam();
  
  Compatibility functions:
  
    $unopened_file = File::Temp::tempnam( $dir, $pfx );
  
  =head1 DESCRIPTION
  
  C<File::Temp> can be used to create and open temporary files in a safe
  way.  There is both a function interface and an object-oriented
  interface.  The File::Temp constructor or the tempfile() function can
  be used to return the name and the open filehandle of a temporary
  file.  The tempdir() function can be used to create a temporary
  directory.
  
  The security aspect of temporary file creation is emphasized such that
  a filehandle and filename are returned together.  This helps guarantee
  that a race condition can not occur where the temporary file is
  created by another process between checking for the existence of the
  file and its opening.  Additional security levels are provided to
  check, for example, that the sticky bit is set on world writable
  directories.  See L<"safe_level"> for more information.
  
  For compatibility with popular C library functions, Perl implementations of
  the mkstemp() family of functions are provided. These are, mkstemp(),
  mkstemps(), mkdtemp() and mktemp().
  
  Additionally, implementations of the standard L<POSIX|POSIX>
  tmpnam() and tmpfile() functions are provided if required.
  
  Implementations of mktemp(), tmpnam(), and tempnam() are provided,
  but should be used with caution since they return only a filename
  that was valid when function was called, so cannot guarantee
  that the file will not exist by the time the caller opens the filename.
  
  Filehandles returned by these functions support the seekable methods.
  
  =begin __INTERNALS
  
  =head1 PORTABILITY
  
  This section is at the top in order to provide easier access to
  porters.  It is not expected to be rendered by a standard pod
  formatting tool. Please skip straight to the SYNOPSIS section if you
  are not trying to port this module to a new platform.
  
  This module is designed to be portable across operating systems and it
  currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
  (Classic). When porting to a new OS there are generally three main
  issues that have to be solved:
  =over 4
  
  =item *
  
  Can the OS unlink an open file? If it can not then the
  C<_can_unlink_opened_file> method should be modified.
  
  =item *
  
  Are the return values from C<stat> reliable? By default all the
  return values from C<stat> are compared when unlinking a temporary
  file using the filename and the handle. Operating systems other than
  unix do not always have valid entries in all fields. If utility function
  C<File::Temp::unlink0> fails then the C<stat> comparison should be
  modified accordingly.
  
  =item *
  
  Security. Systems that can not support a test for the sticky bit
  on a directory can not use the MEDIUM and HIGH security tests.
  The C<_can_do_level> method should be modified accordingly.
  
  =back
  
  =end __INTERNALS
  
  =head1 OBJECT-ORIENTED INTERFACE
  
  This is the primary interface for interacting with
  C<File::Temp>. Using the OO interface a temporary file can be created
  when the object is constructed and the file can be removed when the
  object is no longer required.
  
  Note that there is no method to obtain the filehandle from the
  C<File::Temp> object. The object itself acts as a filehandle.  The object
  isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are
  available.
  
  Also, the object is configured such that it stringifies to the name of the
  temporary file and so can be compared to a filename directly.  It numifies
  to the C<refaddr> the same as other handles and so can be compared to other
  handles with C<==>.
  
      $fh eq $filename       # as a string
      $fh != \*STDOUT        # as a number
  
  =over 4
  
  =item B<new>
  
  Create a temporary file object.
  
    my $tmp = File::Temp->new();
  
  by default the object is constructed as if C<tempfile>
  was called without options, but with the additional behaviour
  that the temporary file is removed by the object destructor
  if UNLINK is set to true (the default).
  
  Supported arguments are the same as for C<tempfile>: UNLINK
  (defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
  template is specified using the TEMPLATE option. The OPEN option
  is not supported (the file is always opened).
  
   $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
                          DIR => 'mydir',
                          SUFFIX => '.dat');
  
  Arguments are case insensitive.
  
  Can call croak() if an error occurs.
  
  =item B<newdir>
  
  Create a temporary directory using an object oriented interface.
  
    $dir = File::Temp->newdir();
  
  By default the directory is deleted when the object goes out of scope.
  
  Supports the same options as the C<tempdir> function. Note that directories
  created with this method default to CLEANUP => 1.
  
    $dir = File::Temp->newdir( $template, %options );
  
  A template may be specified either with a leading template or
  with a TEMPLATE argument.
  
  =item B<filename>
  
  Return the name of the temporary file associated with this object
  (if the object was created using the "new" constructor).
  
    $filename = $tmp->filename;
  
  This method is called automatically when the object is used as
  a string.
  
  =item B<dirname>
  
  Return the name of the temporary directory associated with this
  object (if the object was created using the "newdir" constructor).
  
    $dirname = $tmpdir->dirname;
  
  This method is called automatically when the object is used in string context.
  
  =item B<unlink_on_destroy>
  
  Control whether the file is unlinked when the object goes out of scope.
  The file is removed if this value is true and $KEEP_ALL is not.
  
   $fh->unlink_on_destroy( 1 );
  
  Default is for the file to be removed.
  
  =item B<DESTROY>
  
  When the object goes out of scope, the destructor is called. This
  destructor will attempt to unlink the file (using L<unlink1|"unlink1">)
  if the constructor was called with UNLINK set to 1 (the default state
  if UNLINK is not specified).
  
  No error is given if the unlink fails.
  
  If the object has been passed to a child process during a fork, the
  file will be deleted when the object goes out of scope in the parent.
  
  For a temporary directory object the directory will be removed unless
  the CLEANUP argument was used in the constructor (and set to false) or
  C<unlink_on_destroy> was modified after creation.  Note that if a temp
  directory is your current directory, it cannot be removed - a warning
  will be given in this case.  C<chdir()> out of the directory before
  letting the object go out of scope.
  
  If the global variable $KEEP_ALL is true, the file or directory
  will not be removed.
  
  =back
  
  =head1 FUNCTIONS
  
  This section describes the recommended interface for generating
  temporary files and directories.
  
  =over 4
  
  =item B<tempfile>
  
  This is the basic function to generate temporary files.
  The behaviour of the file can be changed using various options:
  
    $fh = tempfile();
    ($fh, $filename) = tempfile();
  
  Create a temporary file in  the directory specified for temporary
  files, as specified by the tmpdir() function in L<File::Spec>.
  
    ($fh, $filename) = tempfile($template);
  
  Create a temporary file in the current directory using the supplied
  template.  Trailing `X' characters are replaced with random letters to
  generate the filename.  At least four `X' characters must be present
  at the end of the template.
  
    ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
  
  Same as previously, except that a suffix is added to the template
  after the `X' translation.  Useful for ensuring that a temporary
  filename has a particular extension when needed by other applications.
  But see the WARNING at the end.
  
    ($fh, $filename) = tempfile($template, DIR => $dir);
  
  Translates the template as before except that a directory name
  is specified.
  
    ($fh, $filename) = tempfile($template, TMPDIR => 1);
  
  Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
  into the same temporary directory as would be used if no template was
  specified at all.
  
    ($fh, $filename) = tempfile($template, UNLINK => 1);
  
  Return the filename and filehandle as before except that the file is
  automatically removed when the program exits (dependent on
  $KEEP_ALL). Default is for the file to be removed if a file handle is
  requested and to be kept if the filename is requested. In a scalar
  context (where no filename is returned) the file is always deleted
  either (depending on the operating system) on exit or when it is
  closed (unless $KEEP_ALL is true when the temp file is created).
  
  Use the object-oriented interface if fine-grained control of when
  a file is removed is required.
  
  If the template is not specified, a template is always
  automatically generated. This temporary file is placed in tmpdir()
  (L<File::Spec>) unless a directory is specified explicitly with the
  DIR option.
  
    $fh = tempfile( DIR => $dir );
  
  If called in scalar context, only the filehandle is returned and the
  file will automatically be deleted when closed on operating systems
  that support this (see the description of tmpfile() elsewhere in this
  document).  This is the preferred mode of operation, as if you only
  have a filehandle, you can never create a race condition by fumbling
  with the filename. On systems that can not unlink an open file or can
  not mark a file as temporary when it is opened (for example, Windows
  NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
  the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
  flag is ignored if present.
  
    (undef, $filename) = tempfile($template, OPEN => 0);
  
  This will return the filename based on the template but
  will not open this file.  Cannot be used in conjunction with
  UNLINK set to true. Default is to always open the file
  to protect from possible race conditions. A warning is issued
  if warnings are turned on. Consider using the tmpnam()
  and mktemp() functions described elsewhere in this document
  if opening the file is not required.
  
  If the operating system supports it (for example BSD derived systems), the 
  filehandle will be opened with O_EXLOCK (open with exclusive file lock). 
  This can sometimes cause problems if the intention is to pass the filename 
  to another system that expects to take an exclusive lock itself (such as 
  DBD::SQLite) whilst ensuring that the tempfile is not reused. In this 
  situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK 
  will be true (this retains compatibility with earlier releases).
  
    ($fh, $filename) = tempfile($template, EXLOCK => 0);
  
  Options can be combined as required.
  
  Will croak() if there is an error.
  
  =item B<tempdir>
  
  This is the recommended interface for creation of temporary
  directories.  By default the directory will not be removed on exit
  (that is, it won't be temporary; this behaviour can not be changed
  because of issues with backwards compatibility). To enable removal
  either use the CLEANUP option which will trigger removal on program
  exit, or consider using the "newdir" method in the object interface which
  will allow the directory to be cleaned up when the object goes out of
  scope.
  
  The behaviour of the function depends on the arguments:
  
    $tempdir = tempdir();
  
  Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
  
    $tempdir = tempdir( $template );
  
  Create a directory from the supplied template. This template is
  similar to that described for tempfile(). `X' characters at the end
  of the template are replaced with random letters to construct the
  directory name. At least four `X' characters must be in the template.
  
    $tempdir = tempdir ( DIR => $dir );
  
  Specifies the directory to use for the temporary directory.
  The temporary directory name is derived from an internal template.
  
    $tempdir = tempdir ( $template, DIR => $dir );
  
  Prepend the supplied directory name to the template. The template
  should not include parent directory specifications itself. Any parent
  directory specifications are removed from the template before
  prepending the supplied directory.
  
    $tempdir = tempdir ( $template, TMPDIR => 1 );
  
  Using the supplied template, create the temporary directory in
  a standard location for temporary files. Equivalent to doing
  
    $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
  
  but shorter. Parent directory specifications are stripped from the
  template itself. The C<TMPDIR> option is ignored if C<DIR> is set
  explicitly.  Additionally, C<TMPDIR> is implied if neither a template
  nor a directory are supplied.
  
    $tempdir = tempdir( $template, CLEANUP => 1);
  
  Create a temporary directory using the supplied template, but
  attempt to remove it (and all files inside it) when the program
  exits. Note that an attempt will be made to remove all files from
  the directory even if they were not created by this module (otherwise
  why ask to clean it up?). The directory removal is made with
  the rmtree() function from the L<File::Path|File::Path> module.
  Of course, if the template is not specified, the temporary directory
  will be created in tmpdir() and will also be removed at program exit.
  
  Will croak() if there is an error.
  
  =back
  
  =head1 MKTEMP FUNCTIONS
  
  The following functions are Perl implementations of the
  mktemp() family of temp file generation system calls.
  
  =over 4
  
  =item B<mkstemp>
  
  Given a template, returns a filehandle to the temporary file and the name
  of the file.
  
    ($fh, $name) = mkstemp( $template );
  
  In scalar context, just the filehandle is returned.
  
  The template may be any filename with some number of X's appended
  to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
  with unique alphanumeric combinations.
  
  Will croak() if there is an error.
  
  =item B<mkstemps>
  
  Similar to mkstemp(), except that an extra argument can be supplied
  with a suffix to be appended to the template.
  
    ($fh, $name) = mkstemps( $template, $suffix );
  
  For example a template of C<testXXXXXX> and suffix of C<.dat>
  would generate a file similar to F<testhGji_w.dat>.
  
  Returns just the filehandle alone when called in scalar context.
  
  Will croak() if there is an error.
  
  =item B<mkdtemp>
  
  Create a directory from a template. The template must end in
  X's that are replaced by the routine.
  
    $tmpdir_name = mkdtemp($template);
  
  Returns the name of the temporary directory created.
  
  Directory must be removed by the caller.
  
  Will croak() if there is an error.
  
  =item B<mktemp>
  
  Returns a valid temporary filename but does not guarantee
  that the file will not be opened by someone else.
  
    $unopened_file = mktemp($template);
  
  Template is the same as that required by mkstemp().
  
  Will croak() if there is an error.
  
  =back
  
  =head1 POSIX FUNCTIONS
  
  This section describes the re-implementation of the tmpnam()
  and tmpfile() functions described in L<POSIX>
  using the mkstemp() from this module.
  
  Unlike the L<POSIX|POSIX> implementations, the directory used
  for the temporary file is not specified in a system include
  file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
  returned by L<File::Spec|File::Spec>. On some implementations this
  location can be set using the C<TMPDIR> environment variable, which
  may not be secure.
  If this is a problem, simply use mkstemp() and specify a template.
  
  =over 4
  
  =item B<tmpnam>
  
  When called in scalar context, returns the full name (including path)
  of a temporary file (uses mktemp()). The only check is that the file does
  not already exist, but there is no guarantee that that condition will
  continue to apply.
  
    $file = tmpnam();
  
  When called in list context, a filehandle to the open file and
  a filename are returned. This is achieved by calling mkstemp()
  after constructing a suitable template.
  
    ($fh, $file) = tmpnam();
  
  If possible, this form should be used to prevent possible
  race conditions.
  
  See L<File::Spec/tmpdir> for information on the choice of temporary
  directory for a particular operating system.
  
  Will croak() if there is an error.
  
  =item B<tmpfile>
  
  Returns the filehandle of a temporary file.
  
    $fh = tmpfile();
  
  The file is removed when the filehandle is closed or when the program
  exits. No access to the filename is provided.
  
  If the temporary file can not be created undef is returned.
  Currently this command will probably not work when the temporary
  directory is on an NFS file system.
  
  Will croak() if there is an error.
  
  =back
  
  =head1 ADDITIONAL FUNCTIONS
  
  These functions are provided for backwards compatibility
  with common tempfile generation C library functions.
  
  They are not exported and must be addressed using the full package
  name.
  
  =over 4
  
  =item B<tempnam>
  
  Return the name of a temporary file in the specified directory
  using a prefix. The file is guaranteed not to exist at the time
  the function was called, but such guarantees are good for one
  clock tick only.  Always use the proper form of C<sysopen>
  with C<O_CREAT | O_EXCL> if you must open such a filename.
  
    $filename = File::Temp::tempnam( $dir, $prefix );
  
  Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
  (using unix file convention as an example)
  
  Because this function uses mktemp(), it can suffer from race conditions.
  
  Will croak() if there is an error.
  
  =back
  
  =head1 UTILITY FUNCTIONS
  
  Useful functions for dealing with the filehandle and filename.
  
  =over 4
  
  =item B<unlink0>
  
  Given an open filehandle and the associated filename, make a safe
  unlink. This is achieved by first checking that the filename and
  filehandle initially point to the same file and that the number of
  links to the file is 1 (all fields returned by stat() are compared).
  Then the filename is unlinked and the filehandle checked once again to
  verify that the number of links on that file is now 0.  This is the
  closest you can come to making sure that the filename unlinked was the
  same as the file whose descriptor you hold.
  
    unlink0($fh, $path)
       or die "Error unlinking file $path safely";
  
  Returns false on error but croaks() if there is a security
  anomaly. The filehandle is not closed since on some occasions this is
  not required.
  
  On some platforms, for example Windows NT, it is not possible to
  unlink an open file (the file must be closed first). On those
  platforms, the actual unlinking is deferred until the program ends and
  good status is returned. A check is still performed to make sure that
  the filehandle and filename are pointing to the same thing (but not at
  the time the end block is executed since the deferred removal may not
  have access to the filehandle).
  
  Additionally, on Windows NT not all the fields returned by stat() can
  be compared. For example, the C<dev> and C<rdev> fields seem to be
  different.  Also, it seems that the size of the file returned by stat()
  does not always agree, with C<stat(FH)> being more accurate than
  C<stat(filename)>, presumably because of caching issues even when
  using autoflush (this is usually overcome by waiting a while after
  writing to the tempfile before attempting to C<unlink0> it).
  
  Finally, on NFS file systems the link count of the file handle does
  not always go to zero immediately after unlinking. Currently, this
  command is expected to fail on NFS disks.
  
  This function is disabled if the global variable $KEEP_ALL is true
  and an unlink on open file is supported. If the unlink is to be deferred
  to the END block, the file is still registered for removal.
  
  This function should not be called if you are using the object oriented
  interface since the it will interfere with the object destructor deleting
  the file.
  
  =item B<cmpstat>
  
  Compare C<stat> of filehandle with C<stat> of provided filename.  This
  can be used to check that the filename and filehandle initially point
  to the same file and that the number of links to the file is 1 (all
  fields returned by stat() are compared).
  
    cmpstat($fh, $path)
       or die "Error comparing handle with file";
  
  Returns false if the stat information differs or if the link count is
  greater than 1. Calls croak if there is a security anomaly.
  
  On certain platforms, for example Windows, not all the fields returned by stat()
  can be compared. For example, the C<dev> and C<rdev> fields seem to be
  different in Windows.  Also, it seems that the size of the file
  returned by stat() does not always agree, with C<stat(FH)> being more
  accurate than C<stat(filename)>, presumably because of caching issues
  even when using autoflush (this is usually overcome by waiting a while
  after writing to the tempfile before attempting to C<unlink0> it).
  
  Not exported by default.
  
  =item B<unlink1>
  
  Similar to C<unlink0> except after file comparison using cmpstat, the
  filehandle is closed prior to attempting to unlink the file. This
  allows the file to be removed without using an END block, but does
  mean that the post-unlink comparison of the filehandle state provided
  by C<unlink0> is not available.
  
    unlink1($fh, $path)
       or die "Error closing and unlinking file";
  
  Usually called from the object destructor when using the OO interface.
  
  Not exported by default.
  
  This function is disabled if the global variable $KEEP_ALL is true.
  
  Can call croak() if there is a security anomaly during the stat()
  comparison.
  
  =item B<cleanup>
  
  Calling this function will cause any temp files or temp directories
  that are registered for removal to be removed. This happens automatically
  when the process exits but can be triggered manually if the caller is sure
  that none of the temp files are required. This method can be registered as
  an Apache callback.
  
  Note that if a temp directory is your current directory, it cannot be
  removed.  C<chdir()> out of the directory first before calling
  C<cleanup()>. (For the cleanup at program exit when the CLEANUP flag
  is set, this happens automatically.)
  
  On OSes where temp files are automatically removed when the temp file
  is closed, calling this function will have no effect other than to remove
  temporary directories (which may include temporary files).
  
    File::Temp::cleanup();
  
  Not exported by default.
  
  =back
  
  =head1 PACKAGE VARIABLES
  
  These functions control the global state of the package.
  
  =over 4
  
  =item B<safe_level>
  
  Controls the lengths to which the module will go to check the safety of the
  temporary file or directory before proceeding.
  Options are:
  
  =over 8
  
  =item STANDARD
  
  Do the basic security measures to ensure the directory exists and is
  writable, that temporary files are opened only if they do not already
  exist, and that possible race conditions are avoided.  Finally the
  L<unlink0|"unlink0"> function is used to remove files safely.
  
  =item MEDIUM
  
  In addition to the STANDARD security, the output directory is checked
  to make sure that it is owned either by root or the user running the
  program. If the directory is writable by group or by other, it is then
  checked to make sure that the sticky bit is set.
  
  Will not work on platforms that do not support the C<-k> test
  for sticky bit.
  
  =item HIGH
  
  In addition to the MEDIUM security checks, also check for the
  possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
  sysconf() function. If this is a possibility, each directory in the
  path is checked in turn for safeness, recursively walking back to the
  root directory.
  
  For platforms that do not support the L<POSIX|POSIX>
  C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
  assumed that ``chown() giveaway'' is possible and the recursive test
  is performed.
  
  =back
  
  The level can be changed as follows:
  
    File::Temp->safe_level( File::Temp::HIGH );
  
  The level constants are not exported by the module.
  
  Currently, you must be running at least perl v5.6.0 in order to
  run with MEDIUM or HIGH security. This is simply because the
  safety tests use functions from L<Fcntl|Fcntl> that are not
  available in older versions of perl. The problem is that the version
  number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
  they are different versions.
  
  On systems that do not support the HIGH or MEDIUM safety levels
  (for example Win NT or OS/2) any attempt to change the level will
  be ignored. The decision to ignore rather than raise an exception
  allows portable programs to be written with high security in mind
  for the systems that can support this without those programs failing
  on systems where the extra tests are irrelevant.
  
  If you really need to see whether the change has been accepted
  simply examine the return value of C<safe_level>.
  
    $newlevel = File::Temp->safe_level( File::Temp::HIGH );
    die "Could not change to high security"
        if $newlevel != File::Temp::HIGH;
  
  =item TopSystemUID
  
  This is the highest UID on the current system that refers to a root
  UID. This is used to make sure that the temporary directory is
  owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
  simply by root.
  
  This is required since on many unix systems C</tmp> is not owned
  by root.
  
  Default is to assume that any UID less than or equal to 10 is a root
  UID.
  
    File::Temp->top_system_uid(10);
    my $topid = File::Temp->top_system_uid;
  
  This value can be adjusted to reduce security checking if required.
  The value is only relevant when C<safe_level> is set to MEDIUM or higher.
  
  =item B<$KEEP_ALL>
  
  Controls whether temporary files and directories should be retained
  regardless of any instructions in the program to remove them
  automatically.  This is useful for debugging but should not be used in
  production code.
  
    $File::Temp::KEEP_ALL = 1;
  
  Default is for files to be removed as requested by the caller.
  
  In some cases, files will only be retained if this variable is true
  when the file is created. This means that you can not create a temporary
  file, set this variable and expect the temp file to still be around
  when the program exits.
  
  =item B<$DEBUG>
  
  Controls whether debugging messages should be enabled.
  
    $File::Temp::DEBUG = 1;
  
  Default is for debugging mode to be disabled.
  
  =back
  
  =head1 WARNING
  
  For maximum security, endeavour always to avoid ever looking at,
  touching, or even imputing the existence of the filename.  You do not
  know that that filename is connected to the same file as the handle
  you have, and attempts to check this can only trigger more race
  conditions.  It's far more secure to use the filehandle alone and
  dispense with the filename altogether.
  
  If you need to pass the handle to something that expects a filename
  then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for
  arbitrary programs. Perl code that uses the 2-argument version of
  C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you
  will need to pass the filename. You will have to clear the
  close-on-exec bit on that file descriptor before passing it to another
  process.
  
      use Fcntl qw/F_SETFD F_GETFD/;
      fcntl($tmpfh, F_SETFD, 0)
          or die "Can't clear close-on-exec flag on temp fh: $!\n";
  
  =head2 Temporary files and NFS
  
  Some problems are associated with using temporary files that reside
  on NFS file systems and it is recommended that a local filesystem
  is used whenever possible. Some of the security tests will most probably
  fail when the temp file is not local. Additionally, be aware that
  the performance of I/O operations over NFS will not be as good as for
  a local disk.
  
  =head2 Forking
  
  In some cases files created by File::Temp are removed from within an
  END block. Since END blocks are triggered when a child process exits
  (unless C<POSIX::_exit()> is used by the child) File::Temp takes care
  to only remove those temp files created by a particular process ID. This
  means that a child will not attempt to remove temp files created by the
  parent process.
  
  If you are forking many processes in parallel that are all creating
  temporary files, you may need to reset the random number seed using
  srand(EXPR) in each child else all the children will attempt to walk
  through the same set of random file names and may well cause
  themselves to give up if they exceed the number of retry attempts.
  
  =head2 Directory removal
  
  Note that if you have chdir'ed into the temporary directory and it is
  subsequently cleaned up (either in the END block or as part of object
  destruction), then you will get a warning from File::Path::rmtree().
  
  =head2 Taint mode
  
  If you need to run code under taint mode, updating to the latest
  L<File::Spec> is highly recommended.
  
  =head2 BINMODE
  
  The file returned by File::Temp will have been opened in binary mode
  if such a mode is available. If that is not correct, use the C<binmode()>
  function to change the mode of the filehandle.
  
  Note that you can modify the encoding of a file opened by File::Temp
  also by using C<binmode()>.
  
  =head1 HISTORY
  
  Originally began life in May 1999 as an XS interface to the system
  mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
  translated to Perl for total control of the code's
  security checking, to ensure the presence of the function regardless of
  operating system and to help with portability. The module was shipped
  as a standard part of perl from v5.6.1.
  
  Thanks to Tom Christiansen for suggesting that this module
  should be written and providing ideas for code improvements and
  security enhancements.
  
  =head1 SEE ALSO
  
  L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
  
  See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
  different implementations of temporary file handling.
  
  See L<File::Tempdir> for an alternative object-oriented wrapper for
  the C<tempdir> function.
  
  =for Pod::Coverage STRINGIFY NUMIFY top_system_uid
  
  # vim: ts=2 sts=2 sw=2 et:
  
  =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<http://rt.cpan.org/Public/Dist/Display.html?Name=File-Temp>.
  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/Perl-Toolchain-Gang/File-Temp>
  
    git clone https://github.com/Perl-Toolchain-Gang/File-Temp.git
  
  =head1 AUTHOR
  
  Tim Jenness <tjenness@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =over 4
  
  =item *
  
  Ben Tilly <btilly@gmail.com>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  David Steinbrunner <dsteinbrunner@pobox.com>
  
  =item *
  
  Ed Avis <eda@linux01.wcl.local>
  
  =item *
  
  James E. Keenan <jkeen@verizon.net>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Kevin Ryde <user42@zip.com.au>
  
  =item *
  
  Olivier Mengue <dolmen@cpan.org>
  
  =item *
  
  Peter John Acklam <pjacklam@online.no>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Tim Jenness and the UK Particle Physics and Astronomy Research Council.
  
  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
FILE_TEMP

$fatpacked{"File/Which.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_WHICH';
  package File::Which;
  
  use strict;
  use warnings;
  use Exporter   ();
  use File::Spec ();
  
  # ABSTRACT: Perl implementation of the which utility as an API
  our $VERSION = '1.22'; # VERSION
  
  
  our @ISA       = 'Exporter';
  our @EXPORT    = 'which';
  our @EXPORT_OK = 'where';
  
  use constant IS_VMS => ($^O eq 'VMS');
  use constant IS_MAC => ($^O eq 'MacOS');
  use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
  use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys');
  
  # For Win32 systems, stores the extensions used for
  # executable files
  # For others, the empty string is used
  # because 'perl' . '' eq 'perl' => easier
  my @PATHEXT = ('');
  if ( IS_DOS ) {
    # WinNT. PATHEXT might be set on Cygwin, but not used.
    if ( $ENV{PATHEXT} ) {
      push @PATHEXT, split ';', $ENV{PATHEXT};
    } else {
      # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
      push @PATHEXT, qw{.com .exe .bat};
    }
  } elsif ( IS_VMS ) {
    push @PATHEXT, qw{.exe .com};
  } elsif ( IS_CYG ) {
    # See this for more info
    # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe
    push @PATHEXT, qw{.exe .com};
  }
  
  
  sub which {
    my ($exec) = @_;
  
    return undef unless defined $exec;
    return undef if $exec eq '';
  
    my $all = wantarray;
    my @results = ();
  
    # check for aliases first
    if ( IS_VMS ) {
      my $symbol = `SHOW SYMBOL $exec`;
      chomp($symbol);
      unless ( $? ) {
        return $symbol unless $all;
        push @results, $symbol;
      }
    }
    if ( IS_MAC ) {
      my @aliases = split /\,/, $ENV{Aliases};
      foreach my $alias ( @aliases ) {
        # This has not been tested!!
        # PPT which says MPW-Perl cannot resolve `Alias $alias`,
        # let's just hope it's fixed
        if ( lc($alias) eq lc($exec) ) {
          chomp(my $file = `Alias $alias`);
          last unless $file;  # if it failed, just go on the normal way
          return $file unless $all;
          push @results, $file;
          # we can stop this loop as if it finds more aliases matching,
          # it'll just be the same result anyway
          last;
        }
      }
    }
  
    return $exec
            if !IS_VMS and !IS_MAC and !IS_DOS and $exec =~ /\// and -f $exec and -x $exec;
  
    my @path = File::Spec->path;
    if ( IS_DOS or IS_VMS or IS_MAC ) {
      unshift @path, File::Spec->curdir;
    }
  
    foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
      for my $ext ( @PATHEXT ) {
        my $file = $base.$ext;
  
        # We don't want dirs (as they are -x)
        next if -d $file;
  
        if (
          # Executable, normal case
          -x _
          or (
            # MacOS doesn't mark as executable so we check -e
            IS_MAC
            ||
            (
              ( IS_DOS or IS_CYG )
              and
              grep {
                $file =~ /$_\z/i
              } @PATHEXT[1..$#PATHEXT]
            )
            # DOSish systems don't pass -x on
            # non-exe/bat/com files. so we check -e.
            # However, we don't want to pass -e on files
            # that aren't in PATHEXT, like README.
            and -e _
          )
        ) {
          return $file unless $all;
          push @results, $file;
        }
      }
    }
  
    if ( $all ) {
      return @results;
    } else {
      return undef;
    }
  }
  
  
  sub where {
    # force wantarray
    my @res = which($_[0]);
    return @res;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  File::Which - Perl implementation of the which utility as an API
  
  =head1 VERSION
  
  version 1.22
  
  =head1 SYNOPSIS
  
   use File::Which;                  # exports which()
   use File::Which qw(which where);  # exports which() and where()
   
   my $exe_path = which 'perldoc';
   
   my @paths = where 'perl';
   # Or
   my @paths = which 'perl'; # an array forces search for all of them
  
  =head1 DESCRIPTION
  
  L<File::Which> finds the full or relative paths to executable programs on
  the system.  This is normally the function of C<which> utility.  C<which> is
  typically implemented as either a program or a built in shell command.  On
  some platforms, such as Microsoft Windows it is not provided as part of the
  core operating system.  This module provides a consistent API to this
  functionality regardless of the underlying platform.
  
  The focus of this module is correctness and portability.  As a consequence
  platforms where the current directory is implicitly part of the search path
  such as Microsoft Windows will find executables in the current directory,
  whereas on platforms such as UNIX where this is not the case executables 
  in the current directory will only be found if the current directory is
  explicitly added to the path.
  
  If you need a portable C<which> on the command line in an environment that
  does not provide it, install L<App::pwhich> which provides a command line
  interface to this API.
  
  =head2 Implementations
  
  L<File::Which> searches the directories of the user's C<PATH> (the current
  implementation uses L<File::Spec#path> to determine the correct C<PATH>),
  looking for executable files having the name specified as a parameter to
  L</which>. Under Win32 systems, which do not have a notion of directly
  executable files, but uses special extensions such as C<.exe> and C<.bat>
  to identify them, C<File::Which> takes extra steps to assure that
  you will find the correct file (so for example, you might be searching for
  C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)
  
  =head3 Linux, *BSD and other UNIXes
  
  There should not be any surprises here.  The current directory will not be
  searched unless it is explicitly added to the path.
  
  =head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc)
  
  Windows NT has a special environment variable called C<PATHEXT>, which is used
  by the shell to look for executable files. Usually, it will contain a list in
  the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
  environment variable, it parses the list and uses it as the different
  extensions.
  
  =head3 Cygwin
  
  Cygwin provides a Unix-like environment for Microsoft Windows users.  In most
  ways it works like other Unix and Unix-like environments, but in a few key
  aspects it works like Windows.  As with other Unix environments, the current
  directory is not included in the search unless it is explicitly included in
  the search path.  Like on Windows, files with C<.EXE> or <.BAT> extensions will
  be discovered even if they are not part of the query.  C<.COM> or extensions
  specified using the C<PATHEXT> environment variable will NOT be discovered
  without the fully qualified name, however.
  
  =head3 Windows 95, 98, ME, MS-DOS, OS/2
  
  This set of operating systems don't have the C<PATHEXT> variable, and usually
  you will find executable files there with the extensions C<.exe>, C<.bat> and
  (less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
  under Win32 but does not find a C<PATHEXT> variable.
  
  As of 2015 none of these platforms are tested frequently (or perhaps ever),
  but the current maintainer is determined not to intentionally remove support
  for older operating systems.
  
  =head3 VMS
  
  Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
  
  As of 2015 the current maintainer does not test on VMS, and is in fact not
  certain it has ever been tested on VMS.  If this platform is important to you
  and you can help me verify and or support it on that platform please contact
  me.
  
  =head1 FUNCTIONS
  
  =head2 which
  
   my $path = which $short_exe_name;
   my @paths = which $short_exe_name;
  
  Exported by default.
  
  C<$short_exe_name> is the name used in the shell to call the program (for
  example, C<perl>).
  
  If it finds an executable with the name you specified, C<which()> will return
  the absolute path leading to this executable (for example, F</usr/bin/perl> or
  F<C:\Perl\Bin\perl.exe>).
  
  If it does I<not> find the executable, it returns C<undef>.
  
  If C<which()> is called in list context, it will return I<all> the
  matches.
  
  =head2 where
  
   my @paths = where $short_exe_name;
  
  Not exported by default.
  
  Same as L</which> in array context. Same as the
  C<where> utility, will return an array containing all the path names
  matching C<$short_exe_name>.
  
  =head1 CAVEATS
  
  This module has no non-core requirements for Perl 5.6.2 and better.
  
  This module is fully supported back to Perl 5.8.1.  It may work on 5.8.0.  
  It should work on Perl 5.6.x and I may even test on 5.6.2.  I will accept
  patches to maintain compatibility for such older Perls, but you may
  need to fix it on 5.6.x / 5.8.0 and send me a patch.
  
  Not tested on VMS although there is platform specific code
  for those. Anyone who haves a second would be very kind to send me a
  report of how it went.
  
  =head1 SUPPORT
  
  Bugs should be reported via the GitHub issue tracker
  
  L<https://github.com/plicease/File-Which/issues>
  
  For other issues, contact the maintainer.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<pwhich>, L<App::pwhich>
  
  Command line interface to this module.
  
  =item L<IPC::Cmd>
  
  Comes with a C<can_run> function with slightly different semantics that
  the traditional UNIX where.  It will find executables in the current
  directory, even though the current directory is not searched for by
  default on Unix.
  
  =item L<Devel::CheckBin>
  
  This module purports to "check that a command is available", but does not
  provide any documentation on how you might use it.
  
  =back
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Per Einar Ellefsen <pereinar@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =item *
  
  Graham Ollis <plicease@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@cpan.org>.
  
  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
FILE_WHICH

$fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD';
  use strict;
  use warnings;
  
  package File::pushd;
  # ABSTRACT: change directory temporarily for a limited scope
  
  our $VERSION = '1.014';
  
  our @EXPORT = qw( pushd tempd );
  our @ISA    = qw( Exporter );
  
  use Exporter;
  use Carp;
  use Cwd qw( getcwd abs_path );
  use File::Path qw( rmtree );
  use File::Temp qw();
  use File::Spec;
  
  use overload
    q{""}    => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
    fallback => 1;
  
  #--------------------------------------------------------------------------#
  # pushd()
  #--------------------------------------------------------------------------#
  
  sub pushd {
      # Called in void context?
      unless (defined wantarray) {
          warnings::warnif(void => 'Useless use of File::pushd::pushd in void context');
          return
      }
  
      my ( $target_dir, $options ) = @_;
      $options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
  
      $target_dir = "." unless defined $target_dir;
      croak "Can't locate directory $target_dir" unless -d $target_dir;
  
      my $tainted_orig = getcwd;
      my $orig;
      if ( $tainted_orig =~ $options->{untaint_pattern} ) {
          $orig = $1;
      }
      else {
          $orig = $tainted_orig;
      }
  
      my $tainted_dest;
      eval { $tainted_dest = $target_dir ? abs_path($target_dir) : $orig };
      croak "Can't locate absolute path for $target_dir: $@" if $@;
  
      my $dest;
      if ( $tainted_dest =~ $options->{untaint_pattern} ) {
          $dest = $1;
      }
      else {
          $dest = $tainted_dest;
      }
  
      if ( $dest ne $orig ) {
          chdir $dest or croak "Can't chdir to $dest\: $!";
      }
  
      my $self = bless {
          _pushd    => $dest,
          _original => $orig
        },
        __PACKAGE__;
  
      return $self;
  }
  
  #--------------------------------------------------------------------------#
  # tempd()
  #--------------------------------------------------------------------------#
  
  sub tempd {
      # Called in void context?
      unless (defined wantarray) {
          warnings::warnif(void => 'Useless use of File::pushd::tempd in void context');
          return
      }
  
      my ($options) = @_;
      my $dir;
      eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
      croak $@ if $@;
      $dir->{_tempd} = 1;
      return $dir;
  }
  
  #--------------------------------------------------------------------------#
  # preserve()
  #--------------------------------------------------------------------------#
  
  sub preserve {
      my $self = shift;
      return 1 if !$self->{"_tempd"};
      if ( @_ == 0 ) {
          return $self->{_preserve} = 1;
      }
      else {
          return $self->{_preserve} = $_[0] ? 1 : 0;
      }
  }
  
  #--------------------------------------------------------------------------#
  # DESTROY()
  # Revert to original directory as object is destroyed and cleanup
  # if necessary
  #--------------------------------------------------------------------------#
  
  sub DESTROY {
      my ($self) = @_;
      my $orig = $self->{_original};
      chdir $orig if $orig; # should always be so, but just in case...
      if ( $self->{_tempd}
          && !$self->{_preserve} )
      {
          # don't destroy existing $@ if there is no error.
          my $err = do {
              local $@;
              eval { rmtree( $self->{_pushd} ) };
              $@;
          };
          carp $err if $err;
      }
  }
  
  1;
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  File::pushd - change directory temporarily for a limited scope
  
  =head1 VERSION
  
  version 1.014
  
  =head1 SYNOPSIS
  
   use File::pushd;
  
   chdir $ENV{HOME};
  
   # change directory again for a limited scope
   {
       my $dir = pushd( '/tmp' );
       # working directory changed to /tmp
   }
   # working directory has reverted to $ENV{HOME}
  
   # tempd() is equivalent to pushd( File::Temp::tempdir )
   {
       my $dir = tempd();
   }
  
   # object stringifies naturally as an absolute path
   {
      my $dir = pushd( '/tmp' );
      my $filename = File::Spec->catfile( $dir, "somefile.txt" );
      # gives /tmp/somefile.txt
   }
  
  =head1 DESCRIPTION
  
  File::pushd does a temporary C<chdir> that is easily and automatically
  reverted, similar to C<pushd> in some Unix command shells.  It works by
  creating an object that caches the original working directory.  When the object
  is destroyed, the destructor calls C<chdir> to revert to the original working
  directory.  By storing the object in a lexical variable with a limited scope,
  this happens automatically at the end of the scope.
  
  This is very handy when working with temporary directories for tasks like
  testing; a function is provided to streamline getting a temporary
  directory from L<File::Temp>.
  
  For convenience, the object stringifies as the canonical form of the absolute
  pathname of the directory entered.
  
  B<Warning>: if you create multiple C<pushd> objects in the same lexical scope,
  their destruction order is not guaranteed and you might not wind up in the
  directory you expect.
  
  =head1 USAGE
  
   use File::pushd;
  
  Using File::pushd automatically imports the C<pushd> and C<tempd> functions.
  
  =head2 pushd
  
   {
       my $dir = pushd( $target_directory );
   }
  
  Caches the current working directory, calls C<chdir> to change to the target
  directory, and returns a File::pushd object.  When the object is
  destroyed, the working directory reverts to the original directory.
  
  The provided target directory can be a relative or absolute path. If
  called with no arguments, it uses the current directory as its target and
  returns to the current directory when the object is destroyed.
  
  If the target directory does not exist or if the directory change fails
  for some reason, C<pushd> will die with an error message.
  
  Can be given a hashref as an optional second argument.  The only supported
  option is C<untaint_pattern>, which is used to untaint file paths involved.
  It defaults to {qr{^(L<-+@\w./>+)$}}, which is reasonably restrictive (e.g.
  it does not even allow spaces in the path).  Change this to suit your
  circumstances and security needs if running under taint mode. *Note*: you
  must include the parentheses in the pattern to capture the untainted
  portion of the path.
  
  =head2 tempd
  
   {
       my $dir = tempd();
   }
  
  This function is like C<pushd> but automatically creates and calls C<chdir> to
  a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
  cleanup which happens at the end of the program, this temporary directory is
  removed when the object is destroyed. (But also see C<preserve>.)  A warning
  will be issued if the directory cannot be removed.
  
  As with C<pushd>, C<tempd> will die if C<chdir> fails.
  
  It may be given a single options hash that will be passed internally
  to C<pushd>.
  
  =head2 preserve
  
   {
       my $dir = tempd();
       $dir->preserve;      # mark to preserve at end of scope
       $dir->preserve(0);   # mark to delete at end of scope
   }
  
  Controls whether a temporary directory will be cleaned up when the object is
  destroyed.  With no arguments, C<preserve> sets the directory to be preserved.
  With an argument, the directory will be preserved if the argument is true, or
  marked for cleanup if the argument is false.  Only C<tempd> objects may be
  marked for cleanup.  (Target directories to C<pushd> are always preserved.)
  C<preserve> returns true if the directory will be preserved, and false
  otherwise.
  
  =head1 DIAGNOSTICS
  
  C<pushd> and C<tempd> warn with message
  C<"Useless use of File::pushd::I<%s> in void context"> if called in
  void context and the warnings category C<void> is enabled.
  
    {
      use warnings 'void';
  
      pushd();
    }
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<File::chdir>
  
  =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/File-pushd/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/File-pushd>
  
    git clone https://github.com/dagolden/File-pushd.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =for stopwords Diab Jerius Graham Ollis Olivier Mengué
  
  =over 4
  
  =item *
  
  Diab Jerius <djerius@cfa.harvard.edu>
  
  =item *
  
  Graham Ollis <plicease@cpan.org>
  
  =item *
  
  Olivier Mengué <dolmen@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2016 by David A Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
  
  __END__
  
  
  # vim: ts=4 sts=4 sw=4 et:
FILE_PUSHD

$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
  # vim: ts=4 sts=4 sw=4 et:
  package HTTP::Tiny;
  use strict;
  use warnings;
  # ABSTRACT: A small, simple, correct HTTP/1.1 client
  
  our $VERSION = '0.070';
  
  sub _croak { require Carp; Carp::croak(@_) }
  
  #pod =method new
  #pod
  #pod     $http = HTTP::Tiny->new( %attributes );
  #pod
  #pod This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  #pod
  #pod =for :list
  #pod * C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If
  #pod   C<agent> — ends in a space character, the default user-agent string is
  #pod   appended.
  #pod * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class
  #pod   that supports the C<add> and C<cookie_header> methods
  #pod * C<default_headers> — A hashref of default headers to apply to requests
  #pod * C<local_address> — The local IP address to bind to
  #pod * C<keep_alive> — Whether to reuse the last connection (if for the same
  #pod   scheme, host and port) (defaults to 1)
  #pod * C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
  #pod * C<max_size> — Maximum response size in bytes (only when not using a data
  #pod   callback).  If defined, responses larger than this will return an
  #pod   exception.
  #pod * C<http_proxy> — URL of a proxy server to use for HTTP connections
  #pod   (default is C<$ENV{http_proxy}> — if set)
  #pod * C<https_proxy> — URL of a proxy server to use for HTTPS connections
  #pod   (default is C<$ENV{https_proxy}> — if set)
  #pod * C<proxy> — URL of a generic proxy server for both HTTP and HTTPS
  #pod   connections (default is C<$ENV{all_proxy}> — if set)
  #pod * C<no_proxy> — List of domain suffixes that should not be proxied.  Must
  #pod   be a comma-separated string or an array reference. (default is
  #pod   C<$ENV{no_proxy}> —)
  #pod * C<timeout> — Request timeout in seconds (default is 60) If a socket open,
  #pod   read or write takes longer than the timeout, an exception is thrown.
  #pod * C<verify_SSL> — A boolean that indicates whether to validate the SSL
  #pod   certificate of an C<https> — connection (default is false)
  #pod * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to
  #pod   L<IO::Socket::SSL>
  #pod
  #pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
  #pod prevent getting the corresponding proxies from the environment.
  #pod
  #pod Exceptions from C<max_size>, C<timeout> or other errors will result in a
  #pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
  #pod content field in the response will contain the text of the exception.
  #pod
  #pod The C<keep_alive> parameter enables a persistent connection, but only to a
  #pod single destination scheme, host and port.  Also, if any connection-relevant
  #pod attributes are modified, or if the process ID or thread ID change, the
  #pod persistent connection will be dropped.  If you want persistent connections
  #pod across multiple destinations, use multiple HTTP::Tiny objects.
  #pod
  #pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
  #pod
  #pod =cut
  
  my @attributes;
  BEGIN {
      @attributes = qw(
          cookie_jar default_headers http_proxy https_proxy keep_alive
          local_address max_redirect max_size proxy no_proxy
          SSL_options verify_SSL
      );
      my %persist_ok = map {; $_ => 1 } qw(
          cookie_jar default_headers max_redirect max_size
      );
      no strict 'refs';
      no warnings 'uninitialized';
      for my $accessor ( @attributes ) {
          *{$accessor} = sub {
              @_ > 1
                  ? do {
                      delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor};
                      $_[0]->{$accessor} = $_[1]
                  }
                  : $_[0]->{$accessor};
          };
      }
  }
  
  sub agent {
      my($self, $agent) = @_;
      if( @_ > 1 ){
          $self->{agent} =
              (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
      }
      return $self->{agent};
  }
  
  sub timeout {
      my ($self, $timeout) = @_;
      if ( @_ > 1 ) {
          $self->{timeout} = $timeout;
          if ($self->{handle}) {
              $self->{handle}->timeout($timeout);
          }
      }
      return $self->{timeout};
  }
  
  sub new {
      my($class, %args) = @_;
  
      my $self = {
          max_redirect => 5,
          timeout      => defined $args{timeout} ? $args{timeout} : 60,
          keep_alive   => 1,
          verify_SSL   => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
          no_proxy     => $ENV{no_proxy},
      };
  
      bless $self, $class;
  
      $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
  
      for my $key ( @attributes ) {
          $self->{$key} = $args{$key} if exists $args{$key}
      }
  
      $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
  
      $self->_set_proxies;
  
      return $self;
  }
  
  sub _set_proxies {
      my ($self) = @_;
  
      # get proxies from %ENV only if not provided; explicit undef will disable
      # getting proxies from the environment
  
      # generic proxy
      if (! exists $self->{proxy} ) {
          $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
      }
  
      if ( defined $self->{proxy} ) {
          $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
      }
      else {
          delete $self->{proxy};
      }
  
      # http proxy
      if (! exists $self->{http_proxy} ) {
          # under CGI, bypass HTTP_PROXY as request sets it from Proxy header
          local $ENV{HTTP_PROXY} if $ENV{REQUEST_METHOD};
          $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy};
      }
  
      if ( defined $self->{http_proxy} ) {
          $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
          $self->{_has_proxy}{http} = 1;
      }
      else {
          delete $self->{http_proxy};
      }
  
      # https proxy
      if (! exists $self->{https_proxy} ) {
          $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
      }
  
      if ( $self->{https_proxy} ) {
          $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
          $self->{_has_proxy}{https} = 1;
      }
      else {
          delete $self->{https_proxy};
      }
  
      # Split no_proxy to array reference if not provided as such
      unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
          $self->{no_proxy} =
              (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
      }
  
      return;
  }
  
  #pod =method get|head|put|post|delete
  #pod
  #pod     $response = $http->get($url);
  #pod     $response = $http->get($url, \%options);
  #pod     $response = $http->head($url);
  #pod
  #pod These methods are shorthand for calling C<request()> for the given method.  The
  #pod URL must have unsafe characters escaped and international domain names encoded.
  #pod See C<request()> for valid options and a description of the response.
  #pod
  #pod The C<success> field of the response will be true if the status code is 2XX.
  #pod
  #pod =cut
  
  for my $sub_name ( qw/get head put post delete/ ) {
      my $req_method = uc $sub_name;
      no strict 'refs';
      eval <<"HERE"; ## no critic
      sub $sub_name {
          my (\$self, \$url, \$args) = \@_;
          \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
          or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
          return \$self->request('$req_method', \$url, \$args || {});
      }
  HERE
  }
  
  #pod =method post_form
  #pod
  #pod     $response = $http->post_form($url, $form_data);
  #pod     $response = $http->post_form($url, $form_data, \%options);
  #pod
  #pod This method executes a C<POST> request and sends the key/value pairs from a
  #pod form data hash or array reference to the given URL with a C<content-type> of
  #pod C<application/x-www-form-urlencoded>.  If data is provided as an array
  #pod reference, the order is preserved; if provided as a hash reference, the terms
  #pod are sorted on key and value for consistency.  See documentation for the
  #pod C<www_form_urlencode> method for details on the encoding.
  #pod
  #pod The URL must have unsafe characters escaped and international domain names
  #pod encoded.  See C<request()> for valid options and a description of the response.
  #pod Any C<content-type> header or content in the options hashref will be ignored.
  #pod
  #pod The C<success> field of the response will be true if the status code is 2XX.
  #pod
  #pod =cut
  
  sub post_form {
      my ($self, $url, $data, $args) = @_;
      (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
          or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
  
      my $headers = {};
      while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
          $headers->{lc $key} = $value;
      }
      delete $args->{headers};
  
      return $self->request('POST', $url, {
              %$args,
              content => $self->www_form_urlencode($data),
              headers => {
                  %$headers,
                  'content-type' => 'application/x-www-form-urlencoded'
              },
          }
      );
  }
  
  #pod =method mirror
  #pod
  #pod     $response = $http->mirror($url, $file, \%options)
  #pod     if ( $response->{success} ) {
  #pod         print "$file is up to date\n";
  #pod     }
  #pod
  #pod Executes a C<GET> request for the URL and saves the response body to the file
  #pod name provided.  The URL must have unsafe characters escaped and international
  #pod domain names encoded.  If the file already exists, the request will include an
  #pod C<If-Modified-Since> header with the modification timestamp of the file.  You
  #pod may specify a different C<If-Modified-Since> header yourself in the C<<
  #pod $options->{headers} >> hash.
  #pod
  #pod The C<success> field of the response will be true if the status code is 2XX
  #pod or if the status code is 304 (unmodified).
  #pod
  #pod If the file was modified and the server response includes a properly
  #pod formatted C<Last-Modified> header, the file modification time will
  #pod be updated accordingly.
  #pod
  #pod =cut
  
  sub mirror {
      my ($self, $url, $file, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
  
      if ( exists $args->{headers} ) {
          my $headers = {};
          while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
              $headers->{lc $key} = $value;
          }
          $args->{headers} = $headers;
      }
  
      if ( -e $file and my $mtime = (stat($file))[9] ) {
          $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
      }
      my $tempfile = $file . int(rand(2**31));
  
      require Fcntl;
      sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
         or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
      binmode $fh;
      $args->{data_callback} = sub { print {$fh} $_[0] };
      my $response = $self->request('GET', $url, $args);
      close $fh
          or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
  
      if ( $response->{success} ) {
          rename $tempfile, $file
              or _croak(qq/Error replacing $file with $tempfile: $!\n/);
          my $lm = $response->{headers}{'last-modified'};
          if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
              utime $mtime, $mtime, $file;
          }
      }
      $response->{success} ||= $response->{status} eq '304';
      unlink $tempfile;
      return $response;
  }
  
  #pod =method request
  #pod
  #pod     $response = $http->request($method, $url);
  #pod     $response = $http->request($method, $url, \%options);
  #pod
  #pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  #pod 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  #pod international domain names encoded.
  #pod
  #pod If the URL includes a "user:password" stanza, they will be used for Basic-style
  #pod authorization headers.  (Authorization headers will not be included in a
  #pod redirected request.) For example:
  #pod
  #pod     $http->request('GET', 'http://Aladdin:open sesame@example.com/');
  #pod
  #pod If the "user:password" stanza contains reserved characters, they must
  #pod be percent-escaped:
  #pod
  #pod     $http->request('GET', 'http://john%40example.com:password@example.com/');
  #pod
  #pod A hashref of options may be appended to modify the request.
  #pod
  #pod Valid options are:
  #pod
  #pod =for :list
  #pod * C<headers> —
  #pod     A hashref containing headers to include with the request.  If the value for
  #pod     a header is an array reference, the header will be output multiple times with
  #pod     each value in the array.  These headers over-write any default headers.
  #pod * C<content> —
  #pod     A scalar to include as the body of the request OR a code reference
  #pod     that will be called iteratively to produce the body of the request
  #pod * C<trailer_callback> —
  #pod     A code reference that will be called if it exists to provide a hashref
  #pod     of trailing headers (only used with chunked transfer-encoding)
  #pod * C<data_callback> —
  #pod     A code reference that will be called for each chunks of the response
  #pod     body received.
  #pod * C<peer> —
  #pod     Override host resolution and force all connections to go only to a
  #pod     specific peer address, regardless of the URL of the request.  This will
  #pod     include any redirections!  This options should be used with extreme
  #pod     caution (e.g. debugging or very special circumstances).
  #pod
  #pod The C<Host> header is generated from the URL in accordance with RFC 2616.  It
  #pod is a fatal error to specify C<Host> in the C<headers> option.  Other headers
  #pod may be ignored or overwritten if necessary for transport compliance.
  #pod
  #pod If the C<content> option is a code reference, it will be called iteratively
  #pod to provide the content body of the request.  It should return the empty
  #pod string or undef when the iterator is exhausted.
  #pod
  #pod If the C<content> option is the empty string, no C<content-type> or
  #pod C<content-length> headers will be generated.
  #pod
  #pod If the C<data_callback> option is provided, it will be called iteratively until
  #pod the entire response body is received.  The first argument will be a string
  #pod containing a chunk of the response body, the second argument will be the
  #pod in-progress response hash reference, as described below.  (This allows
  #pod customizing the action of the callback based on the C<status> or C<headers>
  #pod received prior to the content body.)
  #pod
  #pod The C<request> method returns a hashref containing the response.  The hashref
  #pod will have the following keys:
  #pod
  #pod =for :list
  #pod * C<success> —
  #pod     Boolean indicating whether the operation returned a 2XX status code
  #pod * C<url> —
  #pod     URL that provided the response. This is the URL of the request unless
  #pod     there were redirections, in which case it is the last URL queried
  #pod     in a redirection chain
  #pod * C<status> —
  #pod     The HTTP status code of the response
  #pod * C<reason> —
  #pod     The response phrase returned by the server
  #pod * C<content> —
  #pod     The body of the response.  If the response does not have any content
  #pod     or if a data callback is provided to consume the response body,
  #pod     this will be the empty string
  #pod * C<headers> —
  #pod     A hashref of header fields.  All header field names will be normalized
  #pod     to be lower case. If a header is repeated, the value will be an arrayref;
  #pod     it will otherwise be a scalar string containing the value
  #pod * C<redirects>
  #pod     If this field exists, it is an arrayref of response hash references from
  #pod     redirects in the same order that redirections occurred.  If it does
  #pod     not exist, then no redirections occurred.
  #pod
  #pod On an exception during the execution of the request, the C<status> field will
  #pod contain 599, and the C<content> field will contain the text of the exception.
  #pod
  #pod =cut
  
  my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
  
  sub request {
      my ($self, $method, $url, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
      $args ||= {}; # we keep some state in this during _request
  
      # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
      my $response;
      for ( 0 .. 1 ) {
          $response = eval { $self->_request($method, $url, $args) };
          last unless $@ && $idempotent{$method}
              && $@ =~ m{^(?:Socket closed|Unexpected end)};
      }
  
      if (my $e = $@) {
          # maybe we got a response hash thrown from somewhere deep
          if ( ref $e eq 'HASH' && exists $e->{status} ) {
              $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []};
              return $e;
          }
  
          # otherwise, stringify it
          $e = "$e";
          $response = {
              url     => $url,
              success => q{},
              status  => 599,
              reason  => 'Internal Exception',
              content => $e,
              headers => {
                  'content-type'   => 'text/plain',
                  'content-length' => length $e,
              },
              ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ),
          };
      }
      return $response;
  }
  
  #pod =method www_form_urlencode
  #pod
  #pod     $params = $http->www_form_urlencode( $data );
  #pod     $response = $http->get("http://example.com/query?$params");
  #pod
  #pod This method converts the key/value pairs from a data hash or array reference
  #pod into a C<x-www-form-urlencoded> string.  The keys and values from the data
  #pod reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  #pod array reference, the key will be repeated with each of the values of the array
  #pod reference.  If data is provided as a hash reference, the key/value pairs in the
  #pod resulting string will be sorted by key and value for consistent ordering.
  #pod
  #pod =cut
  
  sub www_form_urlencode {
      my ($self, $data) = @_;
      (@_ == 2 && ref $data)
          or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
      (ref $data eq 'HASH' || ref $data eq 'ARRAY')
          or _croak("form data must be a hash or array reference\n");
  
      my @params = ref $data eq 'HASH' ? %$data : @$data;
      @params % 2 == 0
          or _croak("form data reference must have an even number of terms\n");
  
      my @terms;
      while( @params ) {
          my ($key, $value) = splice(@params, 0, 2);
          if ( ref $value eq 'ARRAY' ) {
              unshift @params, map { $key => $_ } @$value;
          }
          else {
              push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
          }
      }
  
      return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) );
  }
  
  #pod =method can_ssl
  #pod
  #pod     $ok         = HTTP::Tiny->can_ssl;
  #pod     ($ok, $why) = HTTP::Tiny->can_ssl;
  #pod     ($ok, $why) = $http->can_ssl;
  #pod
  #pod Indicates if SSL support is available.  When called as a class object, it
  #pod checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>.
  #pod When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
  #pod is set in C<SSL_options>, it checks that a CA file is available.
  #pod
  #pod In scalar context, returns a boolean indicating if SSL is available.
  #pod In list context, returns the boolean and a (possibly multi-line) string of
  #pod errors indicating why SSL isn't available.
  #pod
  #pod =cut
  
  sub can_ssl {
      my ($self) = @_;
  
      my($ok, $reason) = (1, '');
  
      # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
      local @INC = @INC;
      pop @INC if $INC[-1] eq '.';
      unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) {
          $ok = 0;
          $reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/;
      }
  
      # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
      unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) {
          $ok = 0;
          $reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/;
      }
  
      # If an object, check that SSL config lets us get a CA if necessary
      if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) {
          my $handle = HTTP::Tiny::Handle->new(
              SSL_options => $self->{SSL_options},
              verify_SSL  => $self->{verify_SSL},
          );
          unless ( eval { $handle->_find_CA_file; 1 } ) {
              $ok = 0;
              $reason .= "$@";
          }
      }
  
      wantarray ? ($ok, $reason) : $ok;
  }
  
  #pod =method connected
  #pod
  #pod     $host = $http->connected;
  #pod     ($host, $port) = $http->connected;
  #pod
  #pod Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
  #pod option.
  #pod
  #pod In scalar context, returns the peer host and port, joined with a colon, or
  #pod C<undef> (if no peer is connected).
  #pod In list context, returns the peer host and port or an empty list (if no peer
  #pod is connected).
  #pod
  #pod B<Note>: This method cannot reliably be used to discover whether the remote
  #pod host has closed its end of the socket.
  #pod
  #pod =cut
  
  sub connected {
      my ($self) = @_;
  
      # If a socket exists...
      if ($self->{handle} && $self->{handle}{fh}) {
          my $socket = $self->{handle}{fh};
  
          # ...and is connected, return the peer host and port.
          if ($socket->connected) {
              return wantarray
                  ? ($socket->peerhost, $socket->peerport)
                  : join(':', $socket->peerhost, $socket->peerport);
          }
      }
      return;
  }
  
  #--------------------------------------------------------------------------#
  # private methods
  #--------------------------------------------------------------------------#
  
  my %DefaultPort = (
      http => 80,
      https => 443,
  );
  
  sub _agent {
      my $class = ref($_[0]) || $_[0];
      (my $default_agent = $class) =~ s{::}{-}g;
      return $default_agent . "/" . $class->VERSION;
  }
  
  sub _request {
      my ($self, $method, $url, $args) = @_;
  
      my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);
  
      my $request = {
          method    => $method,
          scheme    => $scheme,
          host      => $host,
          port      => $port,
          host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
          uri       => $path_query,
          headers   => {},
      };
  
      my $peer = $args->{peer} || $host;
  
      # We remove the cached handle so it is not reused in the case of redirect.
      # If all is well, it will be recached at the end of _request.  We only
      # reuse for the same scheme, host and port
      my $handle = delete $self->{handle};
      if ( $handle ) {
          unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) {
              $handle->close;
              undef $handle;
          }
      }
      $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer );
  
      $self->_prepare_headers_and_cb($request, $args, $url, $auth);
      $handle->write_request($request);
  
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
      my @redir_args = $self->_maybe_redirect($request, $response, $args);
  
      my $known_message_length;
      if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
          # response has no message body
          $known_message_length = 1;
      }
      else {
          # Ignore any data callbacks during redirection.
          my $cb_args = @redir_args ? +{} : $args;
          my $data_cb = $self->_prepare_data_cb($response, $cb_args);
          $known_message_length = $handle->read_body($data_cb, $response);
      }
  
      if ( $self->{keep_alive}
          && $known_message_length
          && $response->{protocol} eq 'HTTP/1.1'
          && ($response->{headers}{connection} || '') ne 'close'
      ) {
          $self->{handle} = $handle;
      }
      else {
          $handle->close;
      }
  
      $response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
      $response->{url} = $url;
  
      # Push the current response onto the stack of redirects if redirecting.
      if (@redir_args) {
          push @{$args->{_redirects}}, $response;
          return $self->_request(@redir_args, $args);
      }
  
      # Copy the stack of redirects into the response before returning.
      $response->{redirects} = delete $args->{_redirects}
        if @{$args->{_redirects}};
      return $response;
  }
  
  sub _open_handle {
      my ($self, $request, $scheme, $host, $port, $peer) = @_;
  
      my $handle  = HTTP::Tiny::Handle->new(
          timeout         => $self->{timeout},
          SSL_options     => $self->{SSL_options},
          verify_SSL      => $self->{verify_SSL},
          local_address   => $self->{local_address},
          keep_alive      => $self->{keep_alive}
      );
  
      if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
          return $self->_proxy_connect( $request, $handle );
      }
      else {
          return $handle->connect($scheme, $host, $port, $peer);
      }
  }
  
  sub _proxy_connect {
      my ($self, $request, $handle) = @_;
  
      my @proxy_vars;
      if ( $request->{scheme} eq 'https' ) {
          _croak(qq{No https_proxy defined}) unless $self->{https_proxy};
          @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
          if ( $proxy_vars[0] eq 'https' ) {
              _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
          }
      }
      else {
          _croak(qq{No http_proxy defined}) unless $self->{http_proxy};
          @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
      }
  
      my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars;
  
      if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) {
          $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
      }
  
      $handle->connect($p_scheme, $p_host, $p_port, $p_host);
  
      if ($request->{scheme} eq 'https') {
          $self->_create_proxy_tunnel( $request, $handle );
      }
      else {
          # non-tunneled proxy requires absolute URI
          $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}";
      }
  
      return $handle;
  }
  
  sub _split_proxy {
      my ($self, $type, $proxy) = @_;
  
      my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) };
  
      unless(
          defined($scheme) && length($scheme) && length($host) && length($port)
          && $path_query eq '/'
      ) {
          _croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
      }
  
      return ($scheme, $host, $port, $auth);
  }
  
  sub _create_proxy_tunnel {
      my ($self, $request, $handle) = @_;
  
      $handle->_assert_ssl;
  
      my $agent = exists($request->{headers}{'user-agent'})
          ? $request->{headers}{'user-agent'} : $self->{agent};
  
      my $connect_request = {
          method    => 'CONNECT',
          uri       => "$request->{host}:$request->{port}",
          headers   => {
              host => "$request->{host}:$request->{port}",
              'user-agent' => $agent,
          }
      };
  
      if ( $request->{headers}{'proxy-authorization'} ) {
          $connect_request->{headers}{'proxy-authorization'} =
              delete $request->{headers}{'proxy-authorization'};
      }
  
      $handle->write_request($connect_request);
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      # if CONNECT failed, throw the response so it will be
      # returned from the original request() method;
      unless (substr($response->{status},0,1) eq '2') {
          die $response;
      }
  
      # tunnel established, so start SSL handshake
      $handle->start_ssl( $request->{host} );
  
      return;
  }
  
  sub _prepare_headers_and_cb {
      my ($self, $request, $args, $url, $auth) = @_;
  
      for ($self->{default_headers}, $args->{headers}) {
          next unless defined;
          while (my ($k, $v) = each %$_) {
              $request->{headers}{lc $k} = $v;
              $request->{header_case}{lc $k} = $k;
          }
      }
  
      if (exists $request->{headers}{'host'}) {
          die(qq/The 'Host' header must not be provided as header option\n/);
      }
  
      $request->{headers}{'host'}         = $request->{host_port};
      $request->{headers}{'user-agent'} ||= $self->{agent};
      $request->{headers}{'connection'}   = "close"
          unless $self->{keep_alive};
  
      if ( defined $args->{content} ) {
          if (ref $args->{content} eq 'CODE') {
              $request->{headers}{'content-type'} ||= "application/octet-stream";
              $request->{headers}{'transfer-encoding'} = 'chunked'
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = $args->{content};
          }
          elsif ( length $args->{content} ) {
              my $content = $args->{content};
              if ( $] ge '5.008' ) {
                  utf8::downgrade($content, 1)
                      or die(qq/Wide character in request message body\n/);
              }
              $request->{headers}{'content-type'} ||= "application/octet-stream";
              $request->{headers}{'content-length'} = length $content
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = sub { substr $content, 0, length $content, '' };
          }
          $request->{trailer_cb} = $args->{trailer_callback}
              if ref $args->{trailer_callback} eq 'CODE';
      }
  
      ### If we have a cookie jar, then maybe add relevant cookies
      if ( $self->{cookie_jar} ) {
          my $cookies = $self->cookie_jar->cookie_header( $url );
          $request->{headers}{cookie} = $cookies if length $cookies;
      }
  
      # if we have Basic auth parameters, add them
      if ( length $auth && ! defined $request->{headers}{authorization} ) {
          $self->_add_basic_auth_header( $request, 'authorization' => $auth );
      }
  
      return;
  }
  
  sub _add_basic_auth_header {
      my ($self, $request, $header, $auth) = @_;
      require MIME::Base64;
      $request->{headers}{$header} =
          "Basic " . MIME::Base64::encode_base64($auth, "");
      return;
  }
  
  sub _prepare_data_cb {
      my ($self, $response, $args) = @_;
      my $data_cb = $args->{data_callback};
      $response->{content} = '';
  
      if (!$data_cb || $response->{status} !~ /^2/) {
          if (defined $self->{max_size}) {
              $data_cb = sub {
                  $_[1]->{content} .= $_[0];
                  die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
                    if length $_[1]->{content} > $self->{max_size};
              };
          }
          else {
              $data_cb = sub { $_[1]->{content} .= $_[0] };
          }
      }
      return $data_cb;
  }
  
  sub _update_cookie_jar {
      my ($self, $url, $response) = @_;
  
      my $cookies = $response->{headers}->{'set-cookie'};
      return unless defined $cookies;
  
      my @cookies = ref $cookies ? @$cookies : $cookies;
  
      $self->cookie_jar->add( $url, $_ ) for @cookies;
  
      return;
  }
  
  sub _validate_cookie_jar {
      my ($class, $jar) = @_;
  
      # duck typing
      for my $method ( qw/add cookie_header/ ) {
          _croak(qq/Cookie jar must provide the '$method' method\n/)
              unless ref($jar) && ref($jar)->can($method);
      }
  
      return;
  }
  
  sub _maybe_redirect {
      my ($self, $request, $response, $args) = @_;
      my $headers = $response->{headers};
      my ($status, $method) = ($response->{status}, $request->{method});
      $args->{_redirects} ||= [];
  
      if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))
          and $headers->{location}
          and @{$args->{_redirects}} < $self->{max_redirect}
      ) {
          my $location = ($headers->{location} =~ /^\//)
              ? "$request->{scheme}://$request->{host_port}$headers->{location}"
              : $headers->{location} ;
          return (($status eq '303' ? 'GET' : $method), $location);
      }
      return;
  }
  
  sub _split_url {
      my $url = pop;
  
      # URI regex adapted from the URI module
      my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
        or die(qq/Cannot parse URL: '$url'\n/);
  
      $scheme     = lc $scheme;
      $path_query = "/$path_query" unless $path_query =~ m<\A/>;
  
      my $auth = '';
      if ( (my $i = index $host, '@') != -1 ) {
          # user:pass@host
          $auth = substr $host, 0, $i, ''; # take up to the @ for auth
          substr $host, 0, 1, '';          # knock the @ off the host
  
          # userinfo might be percent escaped, so recover real auth info
          $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
      }
      my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
               : $scheme eq 'http'                  ? 80
               : $scheme eq 'https'                 ? 443
               : undef;
  
      return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
  }
  
  # Date conversions adapted from HTTP::Date
  my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
  my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
  sub _http_date {
      my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
      return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
          substr($DoW,$wday*4,3),
          $mday, substr($MoY,$mon*4,3), $year+1900,
          $hour, $min, $sec
      );
  }
  
  sub _parse_http_date {
      my ($self, $str) = @_;
      require Time::Local;
      my @tl_parts;
      if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
          @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
      }
      return eval {
          my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
          $t < 0 ? undef : $t;
      };
  }
  
  # URI escaping adapted from URI::Escape
  # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
  # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
  my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
  $escapes{' '}="+";
  my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
  
  sub _uri_escape {
      my ($self, $str) = @_;
      if ( $] ge '5.008' ) {
          utf8::encode($str);
      }
      else {
          $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
              if ( length $str == do { use bytes; length $str } );
          $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
      }
      $str =~ s/($unsafe_char)/$escapes{$1}/ge;
      return $str;
  }
  
  package
      HTTP::Tiny::Handle; # hide from PAUSE/indexers
  use strict;
  use warnings;
  
  use Errno      qw[EINTR EPIPE];
  use IO::Socket qw[SOCK_STREAM];
  use Socket     qw[SOL_SOCKET SO_KEEPALIVE];
  
  # PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
  # behavior if someone is unable to boostrap CPAN from a new perl install; it is
  # not intended for general, per-client use and may be removed in the future
  my $SOCKET_CLASS =
      $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
      eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' :
      'IO::Socket::INET';
  
  sub BUFSIZE () { 32768 } ## no critic
  
  my $Printable = sub {
      local $_ = shift;
      s/\r/\\r/g;
      s/\n/\\n/g;
      s/\t/\\t/g;
      s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
      $_;
  };
  
  my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
  my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;
  
  sub new {
      my ($class, %args) = @_;
      return bless {
          rbuf             => '',
          timeout          => 60,
          max_line_size    => 16384,
          max_header_lines => 64,
          verify_SSL       => 0,
          SSL_options      => {},
          %args
      }, $class;
  }
  
  sub timeout {
      my ($self, $timeout) = @_;
      if ( @_ > 1 ) {
          $self->{timeout} = $timeout;
          if ( $self->{fh} && $self->{fh}->can('timeout') ) {
              $self->{fh}->timeout($timeout);
          }
      }
      return $self->{timeout};
  }
  
  sub connect {
      @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n");
      my ($self, $scheme, $host, $port, $peer) = @_;
  
      if ( $scheme eq 'https' ) {
          $self->_assert_ssl;
      }
      elsif ( $scheme ne 'http' ) {
        die(qq/Unsupported URL scheme '$scheme'\n/);
      }
      $self->{fh} = $SOCKET_CLASS->new(
          PeerHost  => $peer,
          PeerPort  => $port,
          $self->{local_address} ?
              ( LocalAddr => $self->{local_address} ) : (),
          Proto     => 'tcp',
          Type      => SOCK_STREAM,
          Timeout   => $self->{timeout},
      ) or die(qq/Could not connect to '$host:$port': $@\n/);
  
      binmode($self->{fh})
        or die(qq/Could not binmode() socket: '$!'\n/);
  
      if ( $self->{keep_alive} ) {
          unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
              CORE::close($self->{fh});
              die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
          }
      }
  
      $self->start_ssl($host) if $scheme eq 'https';
  
      $self->{scheme} = $scheme;
      $self->{host} = $host;
      $self->{peer} = $peer;
      $self->{port} = $port;
      $self->{pid} = $$;
      $self->{tid} = _get_tid();
  
      return $self;
  }
  
  sub start_ssl {
      my ($self, $host) = @_;
  
      # As this might be used via CONNECT after an SSL session
      # to a proxy, we shut down any existing SSL before attempting
      # the handshake
      if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          unless ( $self->{fh}->stop_SSL ) {
              my $ssl_err = IO::Socket::SSL->errstr;
              die(qq/Error halting prior SSL connection: $ssl_err/);
          }
      }
  
      my $ssl_args = $self->_ssl_args($host);
      IO::Socket::SSL->start_SSL(
          $self->{fh},
          %$ssl_args,
          SSL_create_ctx_callback => sub {
              my $ctx = shift;
              Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
          },
      );
  
      unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          my $ssl_err = IO::Socket::SSL->errstr;
          die(qq/SSL connection failed for $host: $ssl_err\n/);
      }
  }
  
  sub close {
      @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
      my ($self) = @_;
      CORE::close($self->{fh})
        or die(qq/Could not close socket: '$!'\n/);
  }
  
  sub write {
      @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
      my ($self, $buf) = @_;
  
      if ( $] ge '5.008' ) {
          utf8::downgrade($buf, 1)
              or die(qq/Wide character in write()\n/);
      }
  
      my $len = length $buf;
      my $off = 0;
  
      local $SIG{PIPE} = 'IGNORE';
  
      while () {
          $self->can_write
            or die(qq/Timed out while waiting for socket to become ready for writing\n/);
          my $r = syswrite($self->{fh}, $buf, $len, $off);
          if (defined $r) {
              $len -= $r;
              $off += $r;
              last unless $len > 0;
          }
          elsif ($! == EPIPE) {
              die(qq/Socket closed by remote server: $!\n/);
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not write to SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not write to socket: '$!'\n/);
              }
  
          }
      }
      return $off;
  }
  
  sub read {
      @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
      my ($self, $len, $allow_partial) = @_;
  
      my $buf  = '';
      my $got = length $self->{rbuf};
  
      if ($got) {
          my $take = ($got < $len) ? $got : $len;
          $buf  = substr($self->{rbuf}, 0, $take, '');
          $len -= $take;
      }
  
      while ($len > 0) {
          $self->can_read
            or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
          my $r = sysread($self->{fh}, $buf, $len, length $buf);
          if (defined $r) {
              last unless $r;
              $len -= $r;
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not read from SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not read from socket: '$!'\n/);
              }
          }
      }
      if ($len && !$allow_partial) {
          die(qq/Unexpected end of stream\n/);
      }
      return $buf;
  }
  
  sub readline {
      @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
      my ($self) = @_;
  
      while () {
          if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
              return $1;
          }
          if (length $self->{rbuf} >= $self->{max_line_size}) {
              die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
          }
          $self->can_read
            or die(qq/Timed out while waiting for socket to become ready for reading\n/);
          my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
          if (defined $r) {
              last unless $r;
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not read from SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not read from socket: '$!'\n/);
              }
          }
      }
      die(qq/Unexpected end of stream while looking for line\n/);
  }
  
  sub read_header_lines {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
      my ($self, $headers) = @_;
      $headers ||= {};
      my $lines   = 0;
      my $val;
  
      while () {
           my $line = $self->readline;
  
           if (++$lines >= $self->{max_header_lines}) {
               die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
           }
           elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
               my ($field_name) = lc $1;
               if (exists $headers->{$field_name}) {
                   for ($headers->{$field_name}) {
                       $_ = [$_] unless ref $_ eq "ARRAY";
                       push @$_, $2;
                       $val = \$_->[-1];
                   }
               }
               else {
                   $val = \($headers->{$field_name} = $2);
               }
           }
           elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
               $val
                 or die(qq/Unexpected header continuation line\n/);
               next unless length $1;
               $$val .= ' ' if length $$val;
               $$val .= $1;
           }
           elsif ($line =~ /\A \x0D?\x0A \z/x) {
              last;
           }
           else {
              die(q/Malformed header line: / . $Printable->($line) . "\n");
           }
      }
      return $headers;
  }
  
  sub write_request {
      @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
      my($self, $request) = @_;
      $self->write_request_header(@{$request}{qw/method uri headers header_case/});
      $self->write_body($request) if $request->{cb};
      return;
  }
  
  # Standard request header names/case from HTTP/1.1 RFCs
  my @rfc_request_headers = qw(
    Accept Accept-Charset Accept-Encoding Accept-Language Authorization
    Cache-Control Connection Content-Length Expect From Host
    If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
    Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer
    Transfer-Encoding Upgrade User-Agent Via
  );
  
  my @other_request_headers = qw(
    Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin
    X-XSS-Protection
  );
  
  my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers;
  
  # to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
  # combine writes.
  sub write_header_lines {
      (@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n");
      my($self, $headers, $header_case, $prefix_data) = @_;
      $header_case ||= {};
  
      my $buf = (defined $prefix_data ? $prefix_data : '');
  
      # Per RFC, control fields should be listed first
      my %seen;
      for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) {
          next unless exists $headers->{$k};
          $seen{$k}++;
          my $field_name = $HeaderCase{$k};
          my $v = $headers->{$k};
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              $_ = '' unless defined $_;
              $buf .= "$field_name: $_\x0D\x0A";
          }
      }
  
      # Other headers sent in arbitrary order
      while (my ($k, $v) = each %$headers) {
          my $field_name = lc $k;
          next if $seen{$field_name};
          if (exists $HeaderCase{$field_name}) {
              $field_name = $HeaderCase{$field_name};
          }
          else {
              if (exists $header_case->{$field_name}) {
                  $field_name = $header_case->{$field_name};
              }
              else {
                  $field_name =~ s/\b(\w)/\u$1/g;
              }
              $field_name =~ /\A $Token+ \z/xo
                or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
              $HeaderCase{lc $field_name} = $field_name;
          }
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              # unwrap a field value if pre-wrapped by user
              s/\x0D?\x0A\s+/ /g;
              die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n")
                unless $_ eq '' || /\A $Field_Content \z/xo;
              $_ = '' unless defined $_;
              $buf .= "$field_name: $_\x0D\x0A";
          }
      }
      $buf .= "\x0D\x0A";
      return $self->write($buf);
  }
  
  # return value indicates whether message length was defined; this is generally
  # true unless there was no content-length header and we just read until EOF.
  # Other message length errors are thrown as exceptions
  sub read_body {
      @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
      my ($self, $cb, $response) = @_;
      my $te = $response->{headers}{'transfer-encoding'} || '';
      my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
      return $chunked
          ? $self->read_chunked_body($cb, $response)
          : $self->read_content_body($cb, $response);
  }
  
  sub write_body {
      @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
      my ($self, $request) = @_;
      if ($request->{headers}{'content-length'}) {
          return $self->write_content_body($request);
      }
      else {
          return $self->write_chunked_body($request);
      }
  }
  
  sub read_content_body {
      @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
      my ($self, $cb, $response, $content_length) = @_;
      $content_length ||= $response->{headers}{'content-length'};
  
      if ( defined $content_length ) {
          my $len = $content_length;
          while ($len > 0) {
              my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
              $cb->($self->read($read, 0), $response);
              $len -= $read;
          }
          return length($self->{rbuf}) == 0;
      }
  
      my $chunk;
      $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
  
      return;
  }
  
  sub write_content_body {
      @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my ($len, $content_length) = (0, $request->{headers}{'content-length'});
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_content()\n/);
          }
  
          $len += $self->write($data);
      }
  
      $len == $content_length
        or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
  
      return $len;
  }
  
  sub read_chunked_body {
      @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
      my ($self, $cb, $response) = @_;
  
      while () {
          my $head = $self->readline;
  
          $head =~ /\A ([A-Fa-f0-9]+)/x
            or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
  
          my $len = hex($1)
            or last;
  
          $self->read_content_body($cb, $response, $len);
  
          $self->read(2) eq "\x0D\x0A"
            or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
      }
      $self->read_header_lines($response->{headers});
      return 1;
  }
  
  sub write_chunked_body {
      @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my $len = 0;
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_chunked_body()\n/);
          }
  
          $len += length $data;
  
          my $chunk  = sprintf '%X', length $data;
             $chunk .= "\x0D\x0A";
             $chunk .= $data;
             $chunk .= "\x0D\x0A";
  
          $self->write($chunk);
      }
      $self->write("0\x0D\x0A");
      if ( ref $request->{trailer_cb} eq 'CODE' ) {
          $self->write_header_lines($request->{trailer_cb}->())
      }
      else {
          $self->write("\x0D\x0A");
      }
      return $len;
  }
  
  sub read_response_header {
      @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
      my ($self) = @_;
  
      my $line = $self->readline;
  
      $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
        or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
  
      my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
  
      die (qq/Unsupported HTTP protocol: $protocol\n/)
          unless $version =~ /0*1\.0*[01]/;
  
      return {
          status       => $status,
          reason       => $reason,
          headers      => $self->read_header_lines,
          protocol     => $protocol,
      };
  }
  
  sub write_request_header {
      @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
      my ($self, $method, $request_uri, $headers, $header_case) = @_;
  
      return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A");
  }
  
  sub _do_timeout {
      my ($self, $type, $timeout) = @_;
      $timeout = $self->{timeout}
          unless defined $timeout && $timeout >= 0;
  
      my $fd = fileno $self->{fh};
      defined $fd && $fd >= 0
        or die(qq/select(2): 'Bad file descriptor'\n/);
  
      my $initial = time;
      my $pending = $timeout;
      my $nfound;
  
      vec(my $fdset = '', $fd, 1) = 1;
  
      while () {
          $nfound = ($type eq 'read')
              ? select($fdset, undef, undef, $pending)
              : select(undef, $fdset, undef, $pending) ;
          if ($nfound == -1) {
              $! == EINTR
                or die(qq/select(2): '$!'\n/);
              redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
              $nfound = 0;
          }
          last;
      }
      $! = 0;
      return $nfound;
  }
  
  sub can_read {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
      my $self = shift;
      if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          return 1 if $self->{fh}->pending;
      }
      return $self->_do_timeout('read', @_)
  }
  
  sub can_write {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
      my $self = shift;
      return $self->_do_timeout('write', @_)
  }
  
  sub _assert_ssl {
      my($ok, $reason) = HTTP::Tiny->can_ssl();
      die $reason unless $ok;
  }
  
  sub can_reuse {
      my ($self,$scheme,$host,$port,$peer) = @_;
      return 0 if
          $self->{pid} != $$
          || $self->{tid} != _get_tid()
          || length($self->{rbuf})
          || $scheme ne $self->{scheme}
          || $host ne $self->{host}
          || $port ne $self->{port}
          || $peer ne $self->{peer}
          || eval { $self->can_read(0) }
          || $@ ;
          return 1;
  }
  
  # Try to find a CA bundle to validate the SSL cert,
  # prefer Mozilla::CA or fallback to a system file
  sub _find_CA_file {
      my $self = shift();
  
      my $ca_file =
        defined( $self->{SSL_options}->{SSL_ca_file} )
        ? $self->{SSL_options}->{SSL_ca_file}
        : $ENV{SSL_CERT_FILE};
  
      if ( defined $ca_file ) {
          unless ( -r $ca_file ) {
              die qq/SSL_ca_file '$ca_file' not found or not readable\n/;
          }
          return $ca_file;
      }
  
      local @INC = @INC;
      pop @INC if $INC[-1] eq '.';
      return Mozilla::CA::SSL_ca_file()
          if eval { require Mozilla::CA; 1 };
  
      # cert list copied from golang src/crypto/x509/root_unix.go
      foreach my $ca_bundle (
          "/etc/ssl/certs/ca-certificates.crt",     # Debian/Ubuntu/Gentoo etc.
          "/etc/pki/tls/certs/ca-bundle.crt",       # Fedora/RHEL
          "/etc/ssl/ca-bundle.pem",                 # OpenSUSE
          "/etc/openssl/certs/ca-certificates.crt", # NetBSD
          "/etc/ssl/cert.pem",                      # OpenBSD
          "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
          "/etc/pki/tls/cacert.pem",                # OpenELEC
          "/etc/certs/ca-certificates.crt",         # Solaris 11.2+
      ) {
          return $ca_bundle if -e $ca_bundle;
      }
  
      die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
        . qq/Try installing Mozilla::CA from CPAN\n/;
  }
  
  # for thread safety, we need to know thread id if threads are loaded
  sub _get_tid {
      no warnings 'reserved'; # for 'threads'
      return threads->can("tid") ? threads->tid : 0;
  }
  
  sub _ssl_args {
      my ($self, $host) = @_;
  
      my %ssl_args;
  
      # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
      # added until IO::Socket::SSL 1.84
      if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
          $ssl_args{SSL_hostname} = $host,          # Sane SNI support
      }
  
      if ($self->{verify_SSL}) {
          $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
          $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
          $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
          $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
      }
      else {
          $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
          $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
      }
  
      # user options override settings from verify_SSL
      for my $k ( keys %{$self->{SSL_options}} ) {
          $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
      }
  
      return \%ssl_args;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  HTTP::Tiny - A small, simple, correct HTTP/1.1 client
  
  =head1 VERSION
  
  version 0.070
  
  =head1 SYNOPSIS
  
      use HTTP::Tiny;
  
      my $response = HTTP::Tiny->new->get('http://example.com/');
  
      die "Failed!\n" unless $response->{success};
  
      print "$response->{status} $response->{reason}\n";
  
      while (my ($k, $v) = each %{$response->{headers}}) {
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              print "$k: $_\n";
          }
      }
  
      print $response->{content} if length $response->{content};
  
  =head1 DESCRIPTION
  
  This is a very simple HTTP/1.1 client, designed for doing simple
  requests without the overhead of a large framework like L<LWP::UserAgent>.
  
  It is more correct and more complete than L<HTTP::Lite>.  It supports
  proxies and redirection.  It also correctly resumes after EINTR.
  
  If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
  of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.
  
  Cookie support requires L<HTTP::CookieJar> or an equivalent class.
  
  =head1 METHODS
  
  =head2 new
  
      $http = HTTP::Tiny->new( %attributes );
  
  This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  
  =over 4
  
  =item *
  
  C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
  
  =item *
  
  C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
  
  =item *
  
  C<default_headers> — A hashref of default headers to apply to requests
  
  =item *
  
  C<local_address> — The local IP address to bind to
  
  =item *
  
  C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
  
  =item *
  
  C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
  
  =item *
  
  C<max_size> — Maximum response size in bytes (only when not using a data callback).  If defined, responses larger than this will return an exception.
  
  =item *
  
  C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
  
  =item *
  
  C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
  
  =item *
  
  C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
  
  =item *
  
  C<no_proxy> — List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
  
  =item *
  
  C<timeout> — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, an exception is thrown.
  
  =item *
  
  C<verify_SSL> — A boolean that indicates whether to validate the SSL certificate of an C<https> — connection (default is false)
  
  =item *
  
  C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
  
  =back
  
  Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
  prevent getting the corresponding proxies from the environment.
  
  Exceptions from C<max_size>, C<timeout> or other errors will result in a
  pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
  content field in the response will contain the text of the exception.
  
  The C<keep_alive> parameter enables a persistent connection, but only to a
  single destination scheme, host and port.  Also, if any connection-relevant
  attributes are modified, or if the process ID or thread ID change, the
  persistent connection will be dropped.  If you want persistent connections
  across multiple destinations, use multiple HTTP::Tiny objects.
  
  See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
  
  =head2 get|head|put|post|delete
  
      $response = $http->get($url);
      $response = $http->get($url, \%options);
      $response = $http->head($url);
  
  These methods are shorthand for calling C<request()> for the given method.  The
  URL must have unsafe characters escaped and international domain names encoded.
  See C<request()> for valid options and a description of the response.
  
  The C<success> field of the response will be true if the status code is 2XX.
  
  =head2 post_form
  
      $response = $http->post_form($url, $form_data);
      $response = $http->post_form($url, $form_data, \%options);
  
  This method executes a C<POST> request and sends the key/value pairs from a
  form data hash or array reference to the given URL with a C<content-type> of
  C<application/x-www-form-urlencoded>.  If data is provided as an array
  reference, the order is preserved; if provided as a hash reference, the terms
  are sorted on key and value for consistency.  See documentation for the
  C<www_form_urlencode> method for details on the encoding.
  
  The URL must have unsafe characters escaped and international domain names
  encoded.  See C<request()> for valid options and a description of the response.
  Any C<content-type> header or content in the options hashref will be ignored.
  
  The C<success> field of the response will be true if the status code is 2XX.
  
  =head2 mirror
  
      $response = $http->mirror($url, $file, \%options)
      if ( $response->{success} ) {
          print "$file is up to date\n";
      }
  
  Executes a C<GET> request for the URL and saves the response body to the file
  name provided.  The URL must have unsafe characters escaped and international
  domain names encoded.  If the file already exists, the request will include an
  C<If-Modified-Since> header with the modification timestamp of the file.  You
  may specify a different C<If-Modified-Since> header yourself in the C<<
  $options->{headers} >> hash.
  
  The C<success> field of the response will be true if the status code is 2XX
  or if the status code is 304 (unmodified).
  
  If the file was modified and the server response includes a properly
  formatted C<Last-Modified> header, the file modification time will
  be updated accordingly.
  
  =head2 request
  
      $response = $http->request($method, $url);
      $response = $http->request($method, $url, \%options);
  
  Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  international domain names encoded.
  
  If the URL includes a "user:password" stanza, they will be used for Basic-style
  authorization headers.  (Authorization headers will not be included in a
  redirected request.) For example:
  
      $http->request('GET', 'http://Aladdin:open sesame@example.com/');
  
  If the "user:password" stanza contains reserved characters, they must
  be percent-escaped:
  
      $http->request('GET', 'http://john%40example.com:password@example.com/');
  
  A hashref of options may be appended to modify the request.
  
  Valid options are:
  
  =over 4
  
  =item *
  
  C<headers> — A hashref containing headers to include with the request.  If the value for a header is an array reference, the header will be output multiple times with each value in the array.  These headers over-write any default headers.
  
  =item *
  
  C<content> — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request
  
  =item *
  
  C<trailer_callback> — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding)
  
  =item *
  
  C<data_callback> — A code reference that will be called for each chunks of the response body received.
  
  =item *
  
  C<peer> — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request.  This will include any redirections!  This options should be used with extreme caution (e.g. debugging or very special circumstances).
  
  =back
  
  The C<Host> header is generated from the URL in accordance with RFC 2616.  It
  is a fatal error to specify C<Host> in the C<headers> option.  Other headers
  may be ignored or overwritten if necessary for transport compliance.
  
  If the C<content> option is a code reference, it will be called iteratively
  to provide the content body of the request.  It should return the empty
  string or undef when the iterator is exhausted.
  
  If the C<content> option is the empty string, no C<content-type> or
  C<content-length> headers will be generated.
  
  If the C<data_callback> option is provided, it will be called iteratively until
  the entire response body is received.  The first argument will be a string
  containing a chunk of the response body, the second argument will be the
  in-progress response hash reference, as described below.  (This allows
  customizing the action of the callback based on the C<status> or C<headers>
  received prior to the content body.)
  
  The C<request> method returns a hashref containing the response.  The hashref
  will have the following keys:
  
  =over 4
  
  =item *
  
  C<success> — Boolean indicating whether the operation returned a 2XX status code
  
  =item *
  
  C<url> — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain
  
  =item *
  
  C<status> — The HTTP status code of the response
  
  =item *
  
  C<reason> — The response phrase returned by the server
  
  =item *
  
  C<content> — The body of the response.  If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string
  
  =item *
  
  C<headers> — A hashref of header fields.  All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value
  
  =item *
  
  C<redirects> If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred.  If it does not exist, then no redirections occurred.
  
  =back
  
  On an exception during the execution of the request, the C<status> field will
  contain 599, and the C<content> field will contain the text of the exception.
  
  =head2 www_form_urlencode
  
      $params = $http->www_form_urlencode( $data );
      $response = $http->get("http://example.com/query?$params");
  
  This method converts the key/value pairs from a data hash or array reference
  into a C<x-www-form-urlencoded> string.  The keys and values from the data
  reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  array reference, the key will be repeated with each of the values of the array
  reference.  If data is provided as a hash reference, the key/value pairs in the
  resulting string will be sorted by key and value for consistent ordering.
  
  =head2 can_ssl
  
      $ok         = HTTP::Tiny->can_ssl;
      ($ok, $why) = HTTP::Tiny->can_ssl;
      ($ok, $why) = $http->can_ssl;
  
  Indicates if SSL support is available.  When called as a class object, it
  checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>.
  When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
  is set in C<SSL_options>, it checks that a CA file is available.
  
  In scalar context, returns a boolean indicating if SSL is available.
  In list context, returns the boolean and a (possibly multi-line) string of
  errors indicating why SSL isn't available.
  
  =head2 connected
  
      $host = $http->connected;
      ($host, $port) = $http->connected;
  
  Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
  option.
  
  In scalar context, returns the peer host and port, joined with a colon, or
  C<undef> (if no peer is connected).
  In list context, returns the peer host and port or an empty list (if no peer
  is connected).
  
  B<Note>: This method cannot reliably be used to discover whether the remote
  host has closed its end of the socket.
  
  =for Pod::Coverage SSL_options
  agent
  cookie_jar
  default_headers
  http_proxy
  https_proxy
  keep_alive
  local_address
  max_redirect
  max_size
  no_proxy
  proxy
  timeout
  verify_SSL
  
  =head1 SSL SUPPORT
  
  Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
  greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
  thrown if new enough versions of these modules are not installed or if the SSL
  encryption fails. You can also use C<HTTP::Tiny::can_ssl()> utility function
  that returns boolean to see if the required modules are installed.
  
  An C<https> connection may be made via an C<http> proxy that supports the CONNECT
  command (i.e. RFC 2817).  You may not proxy C<https> via a proxy that itself
  requires C<https> to communicate.
  
  SSL provides two distinct capabilities:
  
  =over 4
  
  =item *
  
  Encrypted communication channel
  
  =item *
  
  Verification of server identity
  
  =back
  
  B<By default, HTTP::Tiny does not verify server identity>.
  
  Server identity verification is controversial and potentially tricky because it
  depends on a (usually paid) third-party Certificate Authority (CA) trust model
  to validate a certificate as legitimate.  This discriminates against servers
  with self-signed certificates or certificates signed by free, community-driven
  CA's such as L<CAcert.org|http://cacert.org>.
  
  By default, HTTP::Tiny does not make any assumptions about your trust model,
  threat level or risk tolerance.  It just aims to give you an encrypted channel
  when you need one.
  
  Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
  that an SSL connection has a valid SSL certificate corresponding to the host
  name of the connection and that the SSL certificate has been verified by a CA.
  Assuming you trust the CA, this will protect against a L<man-in-the-middle
  attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>.  If you are
  concerned about security, you should enable this option.
  
  Certificate verification requires a file containing trusted CA certificates.
  
  If the environment variable C<SSL_CERT_FILE> is present, HTTP::Tiny
  will try to find a CA certificate file in that location.
  
  If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
  included with it as a source of trusted CA's.  (This means you trust Mozilla,
  the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
  toolchain used to install it, and your operating system security, right?)
  
  If that module is not available, then HTTP::Tiny will search several
  system-specific default locations for a CA certificate file:
  
  =over 4
  
  =item *
  
  /etc/ssl/certs/ca-certificates.crt
  
  =item *
  
  /etc/pki/tls/certs/ca-bundle.crt
  
  =item *
  
  /etc/ssl/ca-bundle.pem
  
  =back
  
  An exception will be raised if C<verify_SSL> is true and no CA certificate file
  is available.
  
  If you desire complete control over SSL connections, the C<SSL_options> attribute
  lets you provide a hash reference that will be passed through to
  C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
  example, to provide your own trusted CA file:
  
      SSL_options => {
          SSL_ca_file => $file_path,
      }
  
  The C<SSL_options> attribute could also be used for such things as providing a
  client certificate for authentication to a server or controlling the choice of
  cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
  details.
  
  =head1 PROXY SUPPORT
  
  HTTP::Tiny can proxy both C<http> and C<https> requests.  Only Basic proxy
  authorization is supported and it must be provided as part of the proxy URL:
  C<http://user:pass@proxy.example.com/>.
  
  HTTP::Tiny supports the following proxy environment variables:
  
  =over 4
  
  =item *
  
  http_proxy or HTTP_PROXY
  
  =item *
  
  https_proxy or HTTPS_PROXY
  
  =item *
  
  all_proxy or ALL_PROXY
  
  =back
  
  If the C<REQUEST_METHOD> environment variable is set, then this might be a CGI
  process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
  security risk.  If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
  variant only) is ignored.
  
  Tunnelling C<https> over an C<http> proxy using the CONNECT method is
  supported.  If your proxy uses C<https> itself, you can not tunnel C<https>
  over it.
  
  Be warned that proxying an C<https> connection opens you to the risk of a
  man-in-the-middle attack by the proxy server.
  
  The C<no_proxy> environment variable is supported in the format of a
  comma-separated list of domain extensions proxy should not be used for.
  
  Proxy arguments passed to C<new> will override their corresponding
  environment variables.
  
  =head1 LIMITATIONS
  
  HTTP::Tiny is I<conditionally compliant> with the
  L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
  
  =over 4
  
  =item *
  
  "Message Syntax and Routing" [RFC7230]
  
  =item *
  
  "Semantics and Content" [RFC7231]
  
  =item *
  
  "Conditional Requests" [RFC7232]
  
  =item *
  
  "Range Requests" [RFC7233]
  
  =item *
  
  "Caching" [RFC7234]
  
  =item *
  
  "Authentication" [RFC7235]
  
  =back
  
  It attempts to meet all "MUST" requirements of the specification, but does not
  implement all "SHOULD" requirements.  (Note: it was developed against the
  earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
  spec.)
  
  Some particular limitations of note include:
  
  =over
  
  =item *
  
  HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
  that user-defined headers and content are compliant with the HTTP/1.1
  specification.
  
  =item *
  
  Users must ensure that URLs are properly escaped for unsafe characters and that
  international domain names are properly encoded to ASCII. See L<URI::Escape>,
  L<URI::_punycode> and L<Net::IDN::Encode>.
  
  =item *
  
  Redirection is very strict against the specification.  Redirection is only
  automatic for response codes 301, 302, 307 and 308 if the request method is
  'GET' or 'HEAD'.  Response code 303 is always converted into a 'GET'
  redirection, as mandated by the specification.  There is no automatic support
  for status 305 ("Use proxy") redirections.
  
  =item *
  
  There is no provision for delaying a request body using an C<Expect> header.
  Unexpected C<1XX> responses are silently ignored as per the specification.
  
  =item *
  
  Only 'chunked' C<Transfer-Encoding> is supported.
  
  =item *
  
  There is no support for a Request-URI of '*' for the 'OPTIONS' request.
  
  =item *
  
  Headers mentioned in the RFCs and some other, well-known headers are
  generated with their canonical case.  Other headers are sent in the
  case provided by the user.  Except for control headers (which are sent first),
  headers are sent in arbitrary order.
  
  =back
  
  Despite the limitations listed above, HTTP::Tiny is considered
  feature-complete.  New feature requests should be directed to
  L<HTTP::Tiny::UA>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny
  
  =item *
  
  L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
  
  =item *
  
  L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
  
  =item *
  
  L<IO::Socket::IP> - Required for IPv6 support
  
  =item *
  
  L<IO::Socket::SSL> - Required for SSL support
  
  =item *
  
  L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
  
  =item *
  
  L<Mozilla::CA> - Required if you want to validate SSL certificates
  
  =item *
  
  L<Net::SSLeay> - Required for SSL support
  
  =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/chansen/p5-http-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/chansen/p5-http-tiny>
  
    git clone https://github.com/chansen/p5-http-tiny.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Christian Hansen <chansen@cpan.org>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Golden Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Nicolas Rochelemagne Olaf Alders Olivier Mengué Petr Písař SkyMarshal Sören Kornetzki Steve Grazzini Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
  
  =over 4
  
  =item *
  
  Alan Gardner <gardner@pythian.com>
  
  =item *
  
  Alessandro Ghedini <al3xbio@gmail.com>
  
  =item *
  
  A. Sinan Unur <nanis@cpan.org>
  
  =item *
  
  Brad Gilbert <bgills@cpan.org>
  
  =item *
  
  brian m. carlson <sandals@crustytoothpaste.net>
  
  =item *
  
  Chris Nehren <apeiron@cpan.org>
  
  =item *
  
  Chris Weyl <cweyl@alumni.drew.edu>
  
  =item *
  
  Claes Jakobsson <claes@surfar.nu>
  
  =item *
  
  Clinton Gormley <clint@traveljury.com>
  
  =item *
  
  Craig A. Berry <craigberry@mac.com>
  
  =item *
  
  David Golden <xdg@xdg.me>
  
  =item *
  
  Dean Pearce <pearce@pythian.com>
  
  =item *
  
  Edward Zborowski <ed@rubensteintech.com>
  
  =item *
  
  James Raspass <jraspass@gmail.com>
  
  =item *
  
  Jeremy Mates <jmates@cpan.org>
  
  =item *
  
  Jess Robinson <castaway@desert-island.me.uk>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Lukas Eklund <leklund@gmail.com>
  
  =item *
  
  Martin J. Evans <mjegh@ntlworld.com>
  
  =item *
  
  Martin-Louis Bright <mlbright@gmail.com>
  
  =item *
  
  Mike Doherty <doherty@cpan.org>
  
  =item *
  
  Nicolas Rochelemagne <rochelemagne@cpanel.net>
  
  =item *
  
  Olaf Alders <olaf@wundersolutions.com>
  
  =item *
  
  Olivier Mengué <dolmen@cpan.org>
  
  =item *
  
  Petr Písař <ppisar@redhat.com>
  
  =item *
  
  SkyMarshal <skymarshal1729@gmail.com>
  
  =item *
  
  Sören Kornetzki <soeren.kornetzki@delti.com>
  
  =item *
  
  Steve Grazzini <steve.grazzini@grantstreet.com>
  
  =item *
  
  Syohei YOSHIDA <syohex@gmail.com>
  
  =item *
  
  Tatsuhiko Miyagawa <miyagawa@bulknews.net>
  
  =item *
  
  Tom Hukins <tom@eborcom.com>
  
  =item *
  
  Tony Cook <tony@develop-help.com>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2016 by Christian Hansen.
  
  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
HTTP_TINY

$fatpacked{"HTTP/Tinyish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH';
  package HTTP::Tinyish;
  use strict;
  use warnings;
  use Carp ();
  
  our $VERSION = '0.14';
  
  our $PreferredBackend; # for tests
  our @Backends = map "HTTP::Tinyish::$_", qw( LWP HTTPTiny Curl Wget );
  my %configured;
  
  sub new {
      my($class, %attr) = @_;
      bless \%attr, $class;
  }
  
  for my $method (qw/get head put post delete mirror/) {
      no strict 'refs';
      eval <<"HERE";
      sub $method {
          my \$self = shift;
          \$self->_backend_for(\$_[0])->$method(\@_);
      }
  HERE
  }
  
  sub request {
      my $self = shift;
      $self->_backend_for($_[1])->request(@_);
  }
  
  sub _backend_for {
      my($self, $url) = @_;
  
      my($scheme) = $url =~ m!^(https?):!;
      Carp::croak "URL Scheme '$url' not supported." unless $scheme;
  
      for my $backend ($self->backends) {
          $self->configure_backend($backend) or next;
          if ($backend->supports($scheme)) {
              return $backend->new(%$self);
          }
      }
  
      Carp::croak "No backend configured for scheme $scheme";
  }
  
  sub backends {
      $PreferredBackend ? ($PreferredBackend) : @Backends;
  }
  
  sub configure_backend {
      my($self, $backend) = @_;
      unless (exists $configured{$backend}) {
          $configured{$backend} =
            eval { require_module($backend); $backend->configure };
      }
      $configured{$backend};
  }
  
  sub require_module {
      local $_ = shift;
      s!::!/!g;
      require "$_.pm";
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Tinyish - HTTP::Tiny compatible HTTP client wrappers
  
  =head1 SYNOPSIS
  
    my $http = HTTP::Tinyish->new(agent => "Mozilla/4.0");
  
    my $res = $http->get("http://www.cpan.org/");
    warn $res->{status};
  
    $http->post("http://example.com/post", {
        headers => { "Content-Type" => "application/x-www-form-urlencoded" },
        content => "foo=bar&baz=quux",
    });
  
    $http->mirror("http://www.cpan.org/modules/02packages.details.txt.gz", "./02packages.details.txt.gz");
  
  =head1 DESCRIPTION
  
  HTTP::Tinyish is a wrapper module for HTTP client modules
  L<LWP>, L<HTTP::Tiny> and HTTP client software C<curl> and C<wget>.
  
  It provides an API compatible to HTTP::Tiny, and the implementation
  has been extracted out of L<App::cpanminus>. This module can be useful
  in a restrictive environment where you need to be able to download
  CPAN modules without an HTTPS support in built-in HTTP library.
  
  =head1 BACKEND SELECTION
  
  Backends are searched in the order of: C<LWP>, L<HTTP::Tiny>, L<Curl>
  and L<Wget>. HTTP::Tinyish will auto-detect if the backend also
  supports HTTPS, and use the appropriate backend based on the given
  URL to the request methods.
  
  For example, if you only have HTTP::Tiny but without SSL related
  modules, it is possible that:
  
    my $http = HTTP::Tinyish->new;
  
    $http->get("http://example.com");  # uses HTTP::Tiny
    $http->get("https://example.com"); # uses curl
  
  =head1 COMPATIBILITIES
  
  All request related methods such as C<get>, C<post>, C<put>,
  C<delete>, C<request> and C<mirror> are supported.
  
  =head2 LWP
  
  =over 4
  
  =item *
  
  L<LWP> backend requires L<LWP> 5.802 or over to be functional, and L<LWP::Protocol::https> to send HTTPS requests.
  
  =item *
  
  C<mirror> method doesn't consider third options hash into account (i.e. you can't override the HTTP headers).
  
  =item *
  
  proxy is automatically detected from environment variables.
  
  =item *
  
  C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are translated.
  
  =back
  
  =head2 HTTP::Tiny
  
  Because the actual HTTP::Tiny backend is used, all APIs are supported.
  
  =head2 Curl
  
  =over
  
  =item *
  
  This module has been tested with curl 7.22 and later.
  
  =item *
  
  HTTPS support is automatically detected by running C<curl --version> and see its protocol output.
  
  =item *
  
  C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are supported.
  
  =back
  
  =head2 Wget
  
  =over 4
  
  =item *
  
  This module requires Wget 1.12 and later.
  
  =item *
  
  Wget prior to 1.15 doesn't support sending custom HTTP methods, so if you use C<< $http->put >> for example, you'll get an internal error response (599).
  
  =item *
  
  HTTPS support is automatically detected.
  
  =item *
  
  C<mirror()> method doesn't send C<If-Modified-Since> header to the server, which will result in full-download every time because C<wget> doesn't support C<--timestamping> combined with C<-O> option.
  
  =item *
  
  C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are supported.
  
  =back
  
  =head1 SIMILAR MODULES
  
  =over 4
  
  =item *
  
  L<File::Fetch> - is core since 5.10. Has support for non-HTTP protocols such as ftp and git. Does not support HTTPS or basic authentication as of this writing.
  
  =item *
  
  L<Plient> - provides more complete runtime API, but seems only compatible on Unix environments. Does not support mirror() method.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 COPYRIGHT
  
  Tatsuhiko Miyagawa, 2015-
  
  =head1 LICENSE
  
  This module is licensed under the same terms as Perl itself.
  
  =cut
  
HTTP_TINYISH

$fatpacked{"HTTP/Tinyish/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_BASE';
  package HTTP::Tinyish::Base;
  use strict;
  use warnings;
  
  for my $sub_name ( qw/get head put post delete/ ) {
      my $req_method = uc $sub_name;
      eval <<"HERE";
      sub $sub_name {
          my (\$self, \$url, \$args) = \@_;
          \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
          or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
          return \$self->request('$req_method', \$url, \$args || {});
      }
  
  HERE
  }
  
  sub parse_http_header {
      my($self, $header, $res) = @_;
  
      # it might have multiple headers in it because of redirects
      $header =~ s/.*^(HTTP\/\d(?:\.\d)?)/$1/ms;
  
      # grab the first chunk until the line break
      if ($header =~ /^(.*?\x0d?\x0a\x0d?\x0a)/) {
          $header = $1;
      }
  
      # parse into lines
      my @header = split /\x0d?\x0a/,$header;
      my $status_line = shift @header;
  
      # join folded lines
      my @out;
      for (@header) {
          if(/^[ \t]+/) {
              return -1 unless @out;
              $out[-1] .= $_;
          } else {
              push @out, $_;
          }
      }
  
      my($proto, $status, $reason) = split / /, $status_line, 3;
      return unless $proto and $proto =~ /^HTTP\/(\d+)(\.(\d+))?$/i;
  
      $res->{status} = $status;
      $res->{reason} = $reason;
      $res->{success} = $status =~ /^(?:2|304)/;
      $res->{protocol} = $proto;
  
      # import headers
      my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
      my $k;
      for my $header (@out) {
          if ( $header =~ s/^($token): ?// ) {
              $k = lc $1;
          } elsif ( $header =~ /^\s+/) {
              # multiline header
          } else {
              return -1;
          }
  
          if (exists $res->{headers}{$k}) {
              $res->{headers}{$k} = [$res->{headers}{$k}]
                unless ref $res->{headers}{$k};
              push @{$res->{headers}{$k}}, $header;
          } else {
              $res->{headers}{$k} = $header;
          }
      }
  }
  
  sub internal_error {
      my($self, $url, $message) = @_;
  
      return {
          content => $message,
          headers => { "content-length" => length($message), "content-type" => "text/plain" },
          reason  => "Internal Exception",
          status  => 599,
          success => "",
          url     => $url,
      };
  }
  
  1;
HTTP_TINYISH_BASE

$fatpacked{"HTTP/Tinyish/Curl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_CURL';
  package HTTP::Tinyish::Curl;
  use strict;
  use warnings;
  use parent qw(HTTP::Tinyish::Base);
  
  use IPC::Run3 qw(run3);
  use File::Which qw(which);
  use File::Temp ();
  
  my %supports;
  my $curl;
  
  sub _slurp {
      open my $fh, "<", shift or die $!;
      local $/;
      <$fh>;
  }
  
  sub configure {
      my $class = shift;
  
      my %meta;
      $curl = which('curl');
  
      eval {
          run3([$curl, '--version'], \undef, \my $version, \my $error);
          if ($version =~ /^Protocols: (.*)/m) {
              my %protocols = map { $_ => 1 } split /\s/, $1;
              $supports{http}  = 1 if $protocols{http};
              $supports{https} = 1 if $protocols{https};
          }
  
          $meta{$curl} = $version;
      };
  
      \%meta;
  }
  
  sub supports { $supports{$_[1]} }
  
  sub new {
      my($class, %attr) = @_;
      bless \%attr, $class;
  }
  
  sub request {
      my($self, $method, $url, $opts) = @_;
      $opts ||= {};
  
      my(undef, $temp) = File::Temp::tempfile(UNLINK => 1);
  
      my($output, $error);
      eval {
          run3 [
              $curl,
              '-X', $method,
              ($method eq 'HEAD' ? ('--head') : ()),
              $self->build_options($url, $opts),
              '--dump-header', $temp,
              $url,
          ], \undef, \$output, \$error;
      };
  
      if ($@ or $?) {
          return $self->internal_error($url, $@ || $error);
      }
  
      my $res = { url => $url, content => $output };
      $self->parse_http_header( _slurp($temp), $res );
      $res;
  }
  
  sub mirror {
      my($self, $url, $file, $opts) = @_;
      $opts ||= {};
  
      my(undef, $temp) = File::Temp::tempfile(UNLINK => 1);
  
      my($output, $error);
      eval {
          run3 [
              $curl,
              $self->build_options($url, $opts),
              '-z', $file,
              '-o', $file,
              '--dump-header', $temp,
              '--remote-time',
              $url,
          ], \undef, \$output, \$error;
      };
  
      if ($@ or $?) {
          return $self->internal_error($url, $@ || $error);
      }
  
      my $res = { url => $url, content => $output };
      $self->parse_http_header( _slurp($temp), $res );
      $res;
  }
  
  sub build_options {
      my($self, $url, $opts) = @_;
  
      my @options = (
          '--location',
          '--silent',
          '--max-time', ($self->{timeout} || 60),
          '--max-redirs', ($self->{max_redirect} || 5),
          '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
      );
  
      my %headers;
      if ($self->{default_headers}) {
          %headers = %{$self->{default_headers}};
      }
      if ($opts->{headers}) {
          %headers = (%headers, %{$opts->{headers}});
      }
      $self->_translate_headers(\%headers, \@options);
  
      unless ($self->{verify_SSL}) {
          push @options, '--insecure';
      }
  
      if ($opts->{content}) {
          my $content;
          if (ref $opts->{content} eq 'CODE') {
              while (my $chunk = $opts->{content}->()) {
                  $content .= $chunk;
              }
          } else {
              $content = $opts->{content};
          }
          push @options, '--data', $content;
      }
  
      @options;
  }
  
  sub _translate_headers {
      my($self, $headers, $options) = @_;
  
      for my $field (keys %$headers) {
          my $value = $headers->{$field};
          if (ref $value eq 'ARRAY') {
              push @$options, map { ('-H', "$field:$_") } @$value;
          } else {
              push @$options, '-H', "$field:$value";
          }
      }
  }
  
  1;
HTTP_TINYISH_CURL

$fatpacked{"HTTP/Tinyish/HTTPTiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_HTTPTINY';
  package HTTP::Tinyish::HTTPTiny;
  use strict;
  use parent qw(HTTP::Tinyish::Base);
  use HTTP::Tiny;
  
  my %supports = (http => 1);
  
  sub configure {
      my %meta = ("HTTP::Tiny" => $HTTP::Tiny::VERSION);
  
      $supports{https} = HTTP::Tiny->can_ssl;
  
      \%meta;
  }
  
  sub supports { $supports{$_[1]} }
  
  sub new {
      my($class, %attrs) = @_;
      bless {
          tiny => HTTP::Tiny->new(%attrs),
      }, $class;
  }
  
  sub request {
      my $self = shift;
      $self->{tiny}->request(@_);
  }
  
  sub mirror {
      my $self = shift;
      $self->{tiny}->mirror(@_);
  }
  
  1;
  
HTTP_TINYISH_HTTPTINY

$fatpacked{"HTTP/Tinyish/LWP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_LWP';
  package HTTP::Tinyish::LWP;
  use strict;
  use parent qw(HTTP::Tinyish::Base);
  
  use LWP 5.802;
  use LWP::UserAgent;
  
  my %supports = (http => 1);
  
  sub configure {
      my %meta = (
          LWP => $LWP::VERSION,
      );
  
      if (eval { require LWP::Protocol::https; 1 }) {
          $supports{https} = 1;
          $meta{"LWP::Protocol::https"} = $LWP::Protocol::https::VERSION;
      }
  
      \%meta;
  }
  
  sub supports {
      $supports{$_[1]};
  }
  
  sub new {
      my($class, %attr) = @_;
  
      my $ua = LWP::UserAgent->new;
      
      bless {
          ua => $class->translate_lwp($ua, %attr),
      }, $class;
  }
  
  sub _headers_to_hashref {
      my($self, $hdrs) = @_;
  
      my %headers;
      for my $field ($hdrs->header_field_names) {
          $headers{lc $field} = $hdrs->header($field); # could be an array ref
      }
  
      \%headers;
  }
  
  sub request {
      my($self, $method, $url, $opts) = @_;
      $opts ||= {};
  
      my $req = HTTP::Request->new($method => $url);
  
      if ($opts->{headers}) {
          $req->header(%{$opts->{headers}});
      }
  
      if ($opts->{content}) {
          $req->content($opts->{content});
      }
  
      my $res = $self->{ua}->request($req);
  
      if ($self->is_internal_response($res)) {
          return $self->internal_error($url, $res->content);
      }
  
      return {
          url      => $url,
          content  => $res->decoded_content(charset => 'none'),
          success  => $res->is_success,
          status   => $res->code,
          reason   => $res->message,
          headers  => $self->_headers_to_hashref($res->headers),
          protocol => $res->protocol,
      };
  }
  
  sub mirror {
      my($self, $url, $file) = @_;
  
      # TODO support optional headers
      my $res = $self->{ua}->mirror($url, $file);
  
      if ($self->is_internal_response($res)) {
          return $self->internal_error($url, $res->content);
      }
  
      return {
          url      => $url,
          content  => $res->decoded_content,
          success  => $res->is_success || $res->code == 304,
          status   => $res->code,
          reason   => $res->message,
          headers  => $self->_headers_to_hashref($res->headers),
          protocol => $res->protocol,
      };
  }
  
  sub translate_lwp {
      my($class, $agent, %attr) = @_;
  
      $agent->parse_head(0);
      $agent->env_proxy;
      $agent->timeout(delete $attr{timeout} || 60);
      $agent->max_redirect(delete $attr{max_redirect} || 5);
      $agent->agent(delete $attr{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION");
  
      # LWP default is to verify, HTTP::Tiny isn't
      unless ($attr{verify_SSL}) {
          if ($agent->can("ssl_opts")) {
              $agent->ssl_opts(verify_hostname => 0);
          }
      }
  
      if ($attr{default_headers}) {
          $agent->default_headers( HTTP::Headers->new(%{$attr{default_headers}}) );
      }
  
      $agent;
  }
  
  sub is_internal_response {
      my($self, $res) = @_;
  
      $res->code == 500 &&
        ( $res->header('Client-Warning') || '' ) eq 'Internal response';
  }
  
  1;
HTTP_TINYISH_LWP

$fatpacked{"HTTP/Tinyish/Wget.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_WGET';
  package HTTP::Tinyish::Wget;
  use strict;
  use warnings;
  use parent qw(HTTP::Tinyish::Base);
  
  use IPC::Run3 qw(run3);
  use File::Which qw(which);
  
  my %supports;
  my $wget;
  my $method_supported;
  
  sub _run_wget {
      run3([$wget, @_], \undef, \my $out, \my $err);
      wantarray ? ($out, $err) : $out;
  }
  
  sub configure {
      my $class = shift;
      my %meta;
  
      $wget = which('wget');
  
      eval {
          local $ENV{LC_ALL} = 'en_US';
  
          $meta{$wget} = _run_wget('--version');
          unless ($meta{$wget} =~ /GNU Wget 1\.(\d+)/ and $1 >= 12) {
              die "Wget version is too old. $meta{$wget}";
          }
  
          my $config = $class->new(agent => __PACKAGE__);
          my @options = grep { $_ ne '--quiet' } $config->build_options("GET");
  
          my(undef, $err) = _run_wget(@options, 'https://');
          if ($err && $err =~ /HTTPS support not compiled/) {
              $supports{http} = 1;
          } elsif ($err && $err =~ /Invalid host/) {
              $supports{http} = $supports{https} = 1;
          }
  
          (undef, $err) = _run_wget('--method', 'GET', 'http://');
          if ($err && $err =~ /Invalid host/) {
              $method_supported = $meta{method_supported} = 1;
          }
  
      };
  
      \%meta;
  }
  
  sub supports { $supports{$_[1]} }
  
  sub new {
      my($class, %attr) = @_;
      bless \%attr, $class;
  }
  
  sub request {
      my($self, $method, $url, $opts) = @_;
      $opts ||= {};
  
      my($stdout, $stderr);
      eval {
          run3 [
              $wget,
              $self->build_options($method, $url, $opts),
              $url,
              '-O', '-',
          ], \undef, \$stdout, \$stderr;
      };
  
      # wget exit codes: (man wget)
      # 4   Network failure.
      # 5   SSL verification failure.
      # 6   Username/password authentication failure.
      # 7   Protocol errors.
      # 8   Server issued an error response.
      if ($@ or $? && ($? >> 8) <= 5) {
          return $self->internal_error($url, $@ || $stderr);
      }
  
      my $header = '';
      $stderr =~ s{^  (\S.*)$}{ $header .= $1."\n" }gem;
  
      my $res = { url => $url, content => $stdout };
      $self->parse_http_header($header, $res);
      $res;
  }
  
  sub mirror {
      my($self, $url, $file, $opts) = @_;
      $opts ||= {};
  
      # This doesn't send If-Modified-Since because -O and -N are mutually exclusive :(
      my($stdout, $stderr);
      eval {
          run3 [$wget, $self->build_options("GET", $url, $opts), $url, '-O', $file], \undef, \$stdout, \$stderr;
      };
  
      if ($@ or $?) {
          return $self->internal_error($url, $@ || $stderr);
      }
  
      $stderr =~ s/^  //gm;
  
      my $res = { url => $url, content => $stdout };
      $self->parse_http_header($stderr, $res);
      $res;
  }
  
  sub build_options {
      my($self, $method, $url, $opts) = @_;
  
      my @options = (
          '--retry-connrefused',
          '--server-response',
          '--timeout', ($self->{timeout} || 60),
          '--tries', 1,
          '--max-redirect', ($self->{max_redirect} || 5),
          '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
      );
  
      if ($method_supported) {
          push @options, "--method", $method;
      } else {
          if ($method eq 'GET' or $method eq 'POST') {
              # OK
          } elsif ($method eq 'HEAD') {
              push @options, '--spider';
          } else {
              die "This version of wget doesn't support specifying HTTP method '$method'";
          }
      }
  
      if ($self->{agent}) {
          push @options, '--user-agent', $self->{agent};
      }
  
      my %headers;
      if ($self->{default_headers}) {
          %headers = %{$self->{default_headers}};
      }
      if ($opts->{headers}) {
          %headers = (%headers, %{$opts->{headers}});
      }
      $self->_translate_headers(\%headers, \@options);
  
      if ($supports{https} && !$self->{verify_SSL}) {
          push @options, '--no-check-certificate';
      }
  
      if ($opts->{content}) {
          my $content;
          if (ref $opts->{content} eq 'CODE') {
              while (my $chunk = $opts->{content}->()) {
                  $content .= $chunk;
              }
          } else {
              $content = $opts->{content};
          }
  
          if ($method_supported) {
              push @options, '--body-data', $content;
          } else {
              push @options, '--post-data', $content;
          }
      }
  
      @options;
  }
  
  sub _translate_headers {
      my($self, $headers, $options) = @_;
  
      for my $field (keys %$headers) {
          my $value = $headers->{$field};
          if (ref $value eq 'ARRAY') {
              # wget doesn't honor multiple header fields
              push @$options, '--header', "$field:" . join(",", @$value);
          } else {
              push @$options, '--header', "$field:$value";
          }
      }
  }
  
  1;
HTTP_TINYISH_WGET

$fatpacked{"IPC/Cmd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_CMD';
  package IPC::Cmd;
  
  use strict;
  
  BEGIN {
  
      use constant IS_VMS         => $^O eq 'VMS'                       ? 1 : 0;
      use constant IS_WIN32       => $^O eq 'MSWin32'                   ? 1 : 0;
      use constant IS_WIN98       => (IS_WIN32 and !Win32::IsWinNT())   ? 1 : 0;
      use constant ALARM_CLASS    => __PACKAGE__ . '::TimeOut';
      use constant SPECIAL_CHARS  => qw[< > | &];
      use constant QUOTE          => do { IS_WIN32 ? q["] : q['] };
  
      use Exporter    ();
      use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
                          $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
                          $INSTANCES $ALLOW_NULL_ARGS
                          $HAVE_MONOTONIC
                      ];
  
      $VERSION        = '1.00';
      $VERBOSE        = 0;
      $DEBUG          = 0;
      $WARN           = 1;
      $USE_IPC_RUN    = IS_WIN32 && !IS_WIN98;
      $USE_IPC_OPEN3  = not IS_VMS;
      $ALLOW_NULL_ARGS = 0;
  
      $CAN_USE_RUN_FORKED = 0;
      eval {
          require POSIX; POSIX->import();
          require IPC::Open3; IPC::Open3->import();
          require IO::Select; IO::Select->import();
          require IO::Handle; IO::Handle->import();
          require FileHandle; FileHandle->import();
          require Socket;
          require Time::HiRes; Time::HiRes->import();
          require Win32 if IS_WIN32;
      };
      $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
  
      eval {
          my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
      };
      if ($@) {
          $HAVE_MONOTONIC = 0;
      }
      else {
          $HAVE_MONOTONIC = 1;
      }
  
      @ISA            = qw[Exporter];
      @EXPORT_OK      = qw[can_run run run_forked QUOTE];
  }
  
  require Carp;
  use File::Spec;
  use Params::Check               qw[check];
  use Text::ParseWords            ();             # import ONLY if needed!
  use Module::Load::Conditional   qw[can_load];
  use Locale::Maketext::Simple    Style => 'gettext';
  
  local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
  
  =pod
  
  =head1 NAME
  
  IPC::Cmd - finding and running system commands made easy
  
  =head1 SYNOPSIS
  
      use IPC::Cmd qw[can_run run run_forked];
  
      my $full_path = can_run('wget') or warn 'wget is not installed!';
  
      ### commands can be arrayrefs or strings ###
      my $cmd = "$full_path -b theregister.co.uk";
      my $cmd = [$full_path, '-b', 'theregister.co.uk'];
  
      ### in scalar context ###
      my $buffer;
      if( scalar run( command => $cmd,
                      verbose => 0,
                      buffer  => \$buffer,
                      timeout => 20 )
      ) {
          print "fetched webpage successfully: $buffer\n";
      }
  
  
      ### in list context ###
      my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
              run( command => $cmd, verbose => 0 );
  
      if( $success ) {
          print "this is what the command printed:\n";
          print join "", @$full_buf;
      }
  
      ### run_forked example ###
      my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20});
      if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) {
          print "this is what wget returned:\n";
          print $result->{'stdout'};
      }
  
      ### check for features
      print "IPC::Open3 available: "  . IPC::Cmd->can_use_ipc_open3;
      print "IPC::Run available: "    . IPC::Cmd->can_use_ipc_run;
      print "Can capture buffer: "    . IPC::Cmd->can_capture_buffer;
  
      ### don't have IPC::Cmd be verbose, ie don't print to stdout or
      ### stderr when running commands -- default is '0'
      $IPC::Cmd::VERBOSE = 0;
  
  
  =head1 DESCRIPTION
  
  IPC::Cmd allows you to run commands platform independently,
  interactively if desired, but have them still work.
  
  The C<can_run> function can tell you if a certain binary is installed
  and if so where, whereas the C<run> function can actually execute any
  of the commands you give it and give you a clear return value, as well
  as adhere to your verbosity settings.
  
  =head1 CLASS METHODS
  
  =head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
  
  Utility function that tells you if C<IPC::Run> is available.
  If the C<verbose> flag is passed, it will print diagnostic messages
  if L<IPC::Run> can not be found or loaded.
  
  =cut
  
  
  sub can_use_ipc_run     {
      my $self    = shift;
      my $verbose = shift || 0;
  
      ### IPC::Run doesn't run on win98
      return if IS_WIN98;
  
      ### if we don't have ipc::run, we obviously can't use it.
      return unless can_load(
                          modules => { 'IPC::Run' => '0.55' },
                          verbose => ($WARN && $verbose),
                      );
  
      ### otherwise, we're good to go
      return $IPC::Run::VERSION;
  }
  
  =head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
  
  Utility function that tells you if C<IPC::Open3> is available.
  If the verbose flag is passed, it will print diagnostic messages
  if C<IPC::Open3> can not be found or loaded.
  
  =cut
  
  
  sub can_use_ipc_open3   {
      my $self    = shift;
      my $verbose = shift || 0;
  
      ### IPC::Open3 is not working on VMS because of a lack of fork.
      return if IS_VMS;
  
      ### IPC::Open3 works on every non-VMS platform, but it can't
      ### capture buffers on win32 :(
      return unless can_load(
          modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
          verbose => ($WARN && $verbose),
      );
  
      return $IPC::Open3::VERSION;
  }
  
  =head2 $bool = IPC::Cmd->can_capture_buffer
  
  Utility function that tells you if C<IPC::Cmd> is capable of
  capturing buffers in it's current configuration.
  
  =cut
  
  sub can_capture_buffer {
      my $self    = shift;
  
      return 1 if $USE_IPC_RUN    && $self->can_use_ipc_run;
      return 1 if $USE_IPC_OPEN3  && $self->can_use_ipc_open3;
      return;
  }
  
  =head2 $bool = IPC::Cmd->can_use_run_forked
  
  Utility function that tells you if C<IPC::Cmd> is capable of
  providing C<run_forked> on the current platform.
  
  =head1 FUNCTIONS
  
  =head2 $path = can_run( PROGRAM );
  
  C<can_run> takes only one argument: the name of a binary you wish
  to locate. C<can_run> works much like the unix binary C<which> or the bash
  command C<type>, which scans through your path, looking for the requested
  binary.
  
  Unlike C<which> and C<type>, this function is platform independent and
  will also work on, for example, Win32.
  
  If called in a scalar context it will return the full path to the binary
  you asked for if it was found, or C<undef> if it was not.
  
  If called in a list context and the global variable C<$INSTANCES> is a true
  value, it will return a list of the full paths to instances
  of the binary where found in C<PATH>, or an empty list if it was not found.
  
  =cut
  
  sub can_run {
      my $command = shift;
  
      # a lot of VMS executables have a symbol defined
      # check those first
      if ( $^O eq 'VMS' ) {
          require VMS::DCLsym;
          my $syms = VMS::DCLsym->new;
          return $command if scalar $syms->getsym( uc $command );
      }
  
      require File::Spec;
      require ExtUtils::MakeMaker;
  
      my @possibles;
  
      if( File::Spec->file_name_is_absolute($command) ) {
          return MM->maybe_command($command);
  
      } else {
          for my $dir (
              File::Spec->path,
              ( IS_WIN32 ? File::Spec->curdir : () )
          ) {
              next if ! $dir || ! -d $dir;
              my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
              push @possibles, $abs if $abs = MM->maybe_command($abs);
          }
      }
      return @possibles if wantarray and $INSTANCES;
      return shift @possibles;
  }
  
  =head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
  
  C<run> takes 4 arguments:
  
  =over 4
  
  =item command
  
  This is the command to execute. It may be either a string or an array
  reference.
  This is a required argument.
  
  See L<"Caveats"> for remarks on how commands are parsed and their
  limitations.
  
  =item verbose
  
  This controls whether all output of a command should also be printed
  to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
  require L<IPC::Run> to be installed, or your system able to work with
  L<IPC::Open3>).
  
  It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
  which by default is 0.
  
  =item buffer
  
  This will hold all the output of a command. It needs to be a reference
  to a scalar.
  Note that this will hold both the STDOUT and STDERR messages, and you
  have no way of telling which is which.
  If you require this distinction, run the C<run> command in list context
  and inspect the individual buffers.
  
  Of course, this requires that the underlying call supports buffers. See
  the note on buffers above.
  
  =item timeout
  
  Sets the maximum time the command is allowed to run before aborting,
  using the built-in C<alarm()> call. If the timeout is triggered, the
  C<errorcode> in the return value will be set to an object of the
  C<IPC::Cmd::TimeOut> class. See the L<"error message"> section below for
  details.
  
  Defaults to C<0>, meaning no timeout is set.
  
  =back
  
  C<run> will return a simple C<true> or C<false> when called in scalar
  context.
  In list context, you will be returned a list of the following items:
  
  =over 4
  
  =item success
  
  A simple boolean indicating if the command executed without errors or
  not.
  
  =item error message
  
  If the first element of the return value (C<success>) was 0, then some
  error occurred. This second element is the error message the command
  you requested exited with, if available. This is generally a pretty
  printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
  what they can contain.
  If the error was a timeout, the C<error message> will be prefixed with
  the string C<IPC::Cmd::TimeOut>, the timeout class.
  
  =item full_buffer
  
  This is an array reference containing all the output the command
  generated.
  Note that buffers are only available if you have L<IPC::Run> installed,
  or if your system is able to work with L<IPC::Open3> -- see below).
  Otherwise, this element will be C<undef>.
  
  =item out_buffer
  
  This is an array reference containing all the output sent to STDOUT the
  command generated. The notes from L<"full_buffer"> apply.
  
  =item error_buffer
  
  This is an arrayreference containing all the output sent to STDERR the
  command generated. The notes from L<"full_buffer"> apply.
  
  
  =back
  
  See the L<"HOW IT WORKS"> section below to see how C<IPC::Cmd> decides
  what modules or function calls to use when issuing a command.
  
  =cut
  
  {   my @acc = qw[ok error _fds];
  
      ### autogenerate accessors ###
      for my $key ( @acc ) {
          no strict 'refs';
          *{__PACKAGE__."::$key"} = sub {
              $_[0]->{$key} = $_[1] if @_ > 1;
              return $_[0]->{$key};
          }
      }
  }
  
  sub can_use_run_forked {
      return $CAN_USE_RUN_FORKED eq "1";
  }
  
  sub get_monotonic_time {
      if ($HAVE_MONOTONIC) {
          return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
      }
      else {
          return time();
      }
  }
  
  sub adjust_monotonic_start_time {
      my ($ref_vars, $now, $previous) = @_;
  
      # workaround only for those systems which don't have
      # Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular)
      return if $HAVE_MONOTONIC;
  
      # don't have previous monotonic value (only happens once
      # in the beginning of the program execution)
      return unless $previous;
  
      my $time_diff = $now - $previous;
  
      # adjust previously saved time with the skew value which is
      # either negative when clock moved back or more than 5 seconds --
      # assuming that event loop does happen more often than once
      # per five seconds, which might not be always true (!) but
      # hopefully that's ok, because it's just a workaround
      if ($time_diff > 5 || $time_diff < 0) {
          foreach my $ref_var (@{$ref_vars}) {
              if (defined($$ref_var)) {
                  $$ref_var = $$ref_var + $time_diff;
              }
          }
      }
  }
  
  sub uninstall_signals {
  		return unless defined($IPC::Cmd::{'__old_signals'});
  
  		foreach my $sig_name (keys %{$IPC::Cmd::{'__old_signals'}}) {
  				$SIG{$sig_name} = $IPC::Cmd::{'__old_signals'}->{$sig_name};
  		}
  }
  
  # incompatible with POSIX::SigAction
  #
  sub install_layered_signal {
    my ($s, $handler_code) = @_;
  
    my %available_signals = map {$_ => 1} keys %SIG;
  
    Carp::confess("install_layered_signal got nonexistent signal name [$s]")
      unless defined($available_signals{$s});
    Carp::confess("install_layered_signal expects coderef")
      if !ref($handler_code) || ref($handler_code) ne 'CODE';
  
    $IPC::Cmd::{'__old_signals'} = {}
    		unless defined($IPC::Cmd::{'__old_signals'});
  	$IPC::Cmd::{'__old_signals'}->{$s} = $SIG{$s};
  
    my $previous_handler = $SIG{$s};
  
    my $sig_handler = sub {
      my ($called_sig_name, @sig_param) = @_;
  
      # $s is a closure referring to real signal name
      # for which this handler is being installed.
      # it is used to distinguish between
      # real signal handlers and aliased signal handlers
      my $signal_name = $s;
  
      # $called_sig_name is a signal name which
      # was passed to this signal handler;
      # it doesn't equal $signal_name in case
      # some signal handlers in %SIG point
      # to other signal handler (CHLD and CLD,
      # ABRT and IOT)
      #
      # initial signal handler for aliased signal
      # calls some other signal handler which
      # should not execute the same handler_code again
      if ($called_sig_name eq $signal_name) {
        $handler_code->($signal_name);
      }
  
      # run original signal handler if any (including aliased)
      #
      if (ref($previous_handler)) {
        $previous_handler->($called_sig_name, @sig_param);
      }
    };
  
    $SIG{$s} = $sig_handler;
  }
  
  # give process a chance sending TERM,
  # waiting for a while (2 seconds)
  # and killing it with KILL
  sub kill_gently {
    my ($pid, $opts) = @_;
  
    require POSIX;
  
    $opts = {} unless $opts;
    $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
    $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
    $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};
  
    if ($opts->{'first_kill_type'} eq 'just_process') {
      kill(15, $pid);
    }
    elsif ($opts->{'first_kill_type'} eq 'process_group') {
      kill(-15, $pid);
    }
  
    my $do_wait = 1;
    my $child_finished = 0;
  
    my $wait_start_time = get_monotonic_time();
    my $now;
    my $previous_monotonic_value;
  
    while ($do_wait) {
      $previous_monotonic_value = $now;
      $now = get_monotonic_time();
      
      adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value);
  
      if ($now > $wait_start_time + $opts->{'wait_time'}) {
          $do_wait = 0;
          next;
      }
  
      my $waitpid = waitpid($pid, POSIX::WNOHANG);
  
      if ($waitpid eq -1) {
          $child_finished = 1;
          $do_wait = 0;
          next;
      }
      
      Time::HiRes::usleep(250000); # quarter of a second
    }
  
    if (!$child_finished) {
      if ($opts->{'final_kill_type'} eq 'just_process') {
        kill(9, $pid);
      }
      elsif ($opts->{'final_kill_type'} eq 'process_group') {
        kill(-9, $pid);
      }
    }
  }
  
  sub open3_run {
      my ($cmd, $opts) = @_;
  
      $opts = {} unless $opts;
  
      my $child_in = FileHandle->new;
      my $child_out = FileHandle->new;
      my $child_err = FileHandle->new;
      $child_out->autoflush(1);
      $child_err->autoflush(1);
  
      my $pid = open3($child_in, $child_out, $child_err, $cmd);
      Time::HiRes::usleep(1);
  
      # push my child's pid to our parent
      # so in case i am killed parent
      # could stop my child (search for
      # child_child_pid in parent code)
      if ($opts->{'parent_info'}) {
        my $ps = $opts->{'parent_info'};
        print $ps "spawned $pid\n";
      }
  
      if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
          # If the child process dies for any reason,
          # the next write to CHLD_IN is likely to generate
          # a SIGPIPE in the parent, which is fatal by default.
          # So you may wish to handle this signal.
          #
          # from http://perldoc.perl.org/IPC/Open3.html,
          # absolutely needed to catch piped commands errors.
          #
          local $SIG{'PIPE'} = sub { 1; };
  
          print $child_in $opts->{'child_stdin'};
      }
      close($child_in);
  
      my $child_output = {
          'out' => $child_out->fileno,
          'err' => $child_err->fileno,
          $child_out->fileno => {
              'parent_socket' => $opts->{'parent_stdout'},
              'scalar_buffer' => "",
              'child_handle' => $child_out,
              'block_size' => ($child_out->stat)[11] || 1024,
            },
          $child_err->fileno => {
              'parent_socket' => $opts->{'parent_stderr'},
              'scalar_buffer' => "",
              'child_handle' => $child_err,
              'block_size' => ($child_err->stat)[11] || 1024,
            },
          };
  
      my $select = IO::Select->new();
      $select->add($child_out, $child_err);
  
      # pass any signal to the child
      # effectively creating process
      # strongly attached to the child:
      # it will terminate only after child
      # has terminated (except for SIGKILL,
      # which is specially handled)
      SIGNAL: foreach my $s (keys %SIG) {
          next SIGNAL if $s eq '__WARN__' or $s eq '__DIE__'; # Skip and don't clobber __DIE__ & __WARN__
          my $sig_handler;
          $sig_handler = sub {
              kill("$s", $pid);
              $SIG{$s} = $sig_handler;
          };
          $SIG{$s} = $sig_handler;
      }
  
      my $child_finished = 0;
  
      my $real_exit;
      my $exit_value;
  
      while(!$child_finished) {
  
          # parent was killed otherwise we would have got
          # the same signal as parent and process it same way
          if (getppid() eq "1") {
  
            # end my process group with all the children
            # (i am the process group leader, so my pid
            # equals to the process group id)
            #
            # same thing which is done
            # with $opts->{'clean_up_children'}
            # in run_forked
            #
            kill(-9, $$);
  
            POSIX::_exit 1;
          }
  
          my $waitpid = waitpid($pid, POSIX::WNOHANG);
  
          # child finished, catch it's exit status
          if ($waitpid ne 0 && $waitpid ne -1) {
            $real_exit = $?;
            $exit_value = $? >> 8;
          }
  
          if ($waitpid eq -1) {
            $child_finished = 1;
          }
  
  
          my $ready_fds = [];
          push @{$ready_fds}, $select->can_read(1/100);
  
          READY_FDS: while (scalar(@{$ready_fds})) {
              my $fd = shift @{$ready_fds};
              $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
  
              my $str = $child_output->{$fd->fileno};
              Carp::confess("child stream not found: $fd") unless $str;
  
              my $data;
              my $count = $fd->sysread($data, $str->{'block_size'});
  
              if ($count) {
                  if ($str->{'parent_socket'}) {
                      my $ph = $str->{'parent_socket'};
                      print $ph $data;
                  }
                  else {
                      $str->{'scalar_buffer'} .= $data;
                  }
              }
              elsif ($count eq 0) {
                  $select->remove($fd);
                  $fd->close();
              }
              else {
                  Carp::confess("error during sysread: " . $!);
              }
  
              push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
          }
  
          Time::HiRes::usleep(1);
      }
  
      # since we've successfully reaped the child,
      # let our parent know about this.
      #
      if ($opts->{'parent_info'}) {
          my $ps = $opts->{'parent_info'};
  
          # child was killed, inform parent
          if ($real_exit & 127) {
            print $ps "$pid killed with " . ($real_exit & 127) . "\n";
          }
  
          print $ps "reaped $pid\n";
      }
  
      if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
          return $exit_value;
      }
      else {
          return {
              'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
              'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
              'exit_code' => $exit_value,
              };
      }
  }
  
  =head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
  
  C<run_forked> is used to execute some program or a coderef,
  optionally feed it with some input, get its return code
  and output (both stdout and stderr into separate buffers).
  In addition, it allows to terminate the program
  if it takes too long to finish.
  
  The important and distinguishing feature of run_forked
  is execution timeout which at first seems to be
  quite a simple task but if you think
  that the program which you're spawning
  might spawn some children itself (which
  in their turn could do the same and so on)
  it turns out to be not a simple issue.
  
  C<run_forked> is designed to survive and
  successfully terminate almost any long running task,
  even a fork bomb in case your system has the resources
  to survive during given timeout.
  
  This is achieved by creating separate watchdog process
  which spawns the specified program in a separate
  process session and supervises it: optionally
  feeds it with input, stores its exit code,
  stdout and stderr, terminates it in case
  it runs longer than specified.
  
  Invocation requires the command to be executed or a coderef and optionally a hashref of options:
  
  =over
  
  =item C<timeout>
  
  Specify in seconds how long to run the command before it is killed with SIG_KILL (9),
  which effectively terminates it and all of its children (direct or indirect).
  
  =item C<child_stdin>
  
  Specify some text that will be passed into the C<STDIN> of the executed program.
  
  =item C<stdout_handler>
  
  Coderef of a subroutine to call when a portion of data is received on
  STDOUT from the executing program.
  
  =item C<stderr_handler>
  
  Coderef of a subroutine to call when a portion of data is received on
  STDERR from the executing program.
  
  =item C<wait_loop_callback>
  
  Coderef of a subroutine to call inside of the main waiting loop
  (while C<run_forked> waits for the external to finish or fail).
  It is useful to stop running external process before it ends
  by itself, e.g.
  
    my $r = run_forked("some external command", {
  	  'wait_loop_callback' => sub {
            if (condition) {
                kill(1, $$);
            }
  	  },
  	  'terminate_on_signal' => 'HUP',
  	  });
  
  Combined with C<stdout_handler> and C<stderr_handler> allows terminating
  external command based on its output. Could also be used as a timer
  without engaging with L<alarm> (signals).
  
  Remember that this code could be called every millisecond (depending
  on the output which external command generates), so try to make it
  as lightweight as possible.
  
  =item C<discard_output>
  
  Discards the buffering of the standard output and standard errors for return by run_forked().
  With this option you have to use the std*_handlers to read what the command outputs.
  Useful for commands that send a lot of output.
  
  =item C<terminate_on_parent_sudden_death>
  
  Enable this option if you wish all spawned processes to be killed if the initially spawned
  process (the parent) is killed or dies without waiting for child processes.
  
  =back
  
  C<run_forked> will return a HASHREF with the following keys:
  
  =over
  
  =item C<exit_code>
  
  The exit code of the executed program.
  
  =item C<timeout>
  
  The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
  
  =item C<stdout>
  
  Holds the standard output of the executed command (or empty string if
  there was no STDOUT output or if C<discard_output> was used; it's always defined!)
  
  =item C<stderr>
  
  Holds the standard error of the executed command (or empty string if
  there was no STDERR output or if C<discard_output> was used; it's always defined!)
  
  =item C<merged>
  
  Holds the standard output and error of the executed command merged into one stream
  (or empty string if there was no output at all or if C<discard_output> was used; it's always defined!)
  
  =item C<err_msg>
  
  Holds some explanation in the case of an error.
  
  =back
  
  =cut
  
  sub run_forked {
      ### container to store things in
      my $self = bless {}, __PACKAGE__;
  
      if (!can_use_run_forked()) {
          Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
          return;
      }
  
      require POSIX;
  
      my ($cmd, $opts) = @_;
      if (ref($cmd) eq 'ARRAY') {
          $cmd = join(" ", @{$cmd});
      }
  
      if (!$cmd) {
          Carp::carp("run_forked expects command to run");
          return;
      }
  
      $opts = {} unless $opts;
      $opts->{'timeout'} = 0 unless $opts->{'timeout'};
      $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
  
      # turned on by default
      $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
  
      # sockets to pass child stdout to parent
      my $child_stdout_socket;
      my $parent_stdout_socket;
  
      # sockets to pass child stderr to parent
      my $child_stderr_socket;
      my $parent_stderr_socket;
  
      # sockets for child -> parent internal communication
      my $child_info_socket;
      my $parent_info_socket;
  
      socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
        Carp::confess ("socketpair: $!");
      socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
        Carp::confess ("socketpair: $!");
      socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
        Carp::confess ("socketpair: $!");
  
      $child_stdout_socket->autoflush(1);
      $parent_stdout_socket->autoflush(1);
      $child_stderr_socket->autoflush(1);
      $parent_stderr_socket->autoflush(1);
      $child_info_socket->autoflush(1);
      $parent_info_socket->autoflush(1);
  
      my $start_time = get_monotonic_time();
  
      my $pid;
      if ($pid = fork) {
  
        # we are a parent
        close($parent_stdout_socket);
        close($parent_stderr_socket);
        close($parent_info_socket);
  
        my $flags;
  
        # prepare sockets to read from child
  
        $flags = fcntl($child_stdout_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
        $flags |= POSIX::O_NONBLOCK;
        fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
  
        $flags = fcntl($child_stderr_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
        $flags |= POSIX::O_NONBLOCK;
        fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
  
        $flags = fcntl($child_info_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
        $flags |= POSIX::O_NONBLOCK;
        fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
  
    #    print "child $pid started\n";
  
        my $child_output = {
          $child_stdout_socket->fileno => {
            'scalar_buffer' => "",
            'child_handle' => $child_stdout_socket,
            'block_size' => ($child_stdout_socket->stat)[11] || 1024,
            'protocol' => 'stdout',
            },
          $child_stderr_socket->fileno => {
            'scalar_buffer' => "",
            'child_handle' => $child_stderr_socket,
            'block_size' => ($child_stderr_socket->stat)[11] || 1024,
            'protocol' => 'stderr',
            },
          $child_info_socket->fileno => {
            'scalar_buffer' => "",
            'child_handle' => $child_info_socket,
            'block_size' => ($child_info_socket->stat)[11] || 1024,
            'protocol' => 'info',
            },
          };
  
        my $select = IO::Select->new();
        $select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket);
  
        my $child_timedout = 0;
        my $child_finished = 0;
        my $child_stdout = '';
        my $child_stderr = '';
        my $child_merged = '';
        my $child_exit_code = 0;
        my $child_killed_by_signal = 0;
        my $parent_died = 0;
  
        my $last_parent_check = 0;
        my $got_sig_child = 0;
        my $got_sig_quit = 0;
        my $orig_sig_child = $SIG{'CHLD'};
  
        $SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); };
  
        if ($opts->{'terminate_on_signal'}) {
          install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
        }
  
        my $child_child_pid;
        my $now;
        my $previous_monotonic_value;
  
        while (!$child_finished) {
          $previous_monotonic_value = $now;
          $now = get_monotonic_time();
  
          adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value);
  
          if ($opts->{'terminate_on_parent_sudden_death'}) {
            # check for parent once each five seconds
            if ($now > $last_parent_check + 5) {
              if (getppid() eq "1") {
                kill_gently ($pid, {
                  'first_kill_type' => 'process_group',
                  'final_kill_type' => 'process_group',
                  'wait_time' => $opts->{'terminate_wait_time'}
                  });
                $parent_died = 1;
              }
  
              $last_parent_check = $now;
            }
          }
  
          # user specified timeout
          if ($opts->{'timeout'}) {
            if ($now > $start_time + $opts->{'timeout'}) {
              kill_gently ($pid, {
                'first_kill_type' => 'process_group',
                'final_kill_type' => 'process_group',
                'wait_time' => $opts->{'terminate_wait_time'}
                });
              $child_timedout = 1;
            }
          }
  
          # give OS 10 seconds for correct return of waitpid,
          # kill process after that and finish wait loop;
          # shouldn't ever happen -- remove this code?
          if ($got_sig_child) {
            if ($now > $got_sig_child + 10) {
              print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
              kill (-9, $pid);
              $child_finished = 1;
            }
          }
  
          if ($got_sig_quit) {
            kill_gently ($pid, {
              'first_kill_type' => 'process_group',
              'final_kill_type' => 'process_group',
              'wait_time' => $opts->{'terminate_wait_time'}
              });
            $child_finished = 1;
          }
  
          my $waitpid = waitpid($pid, POSIX::WNOHANG);
  
          # child finished, catch it's exit status
          if ($waitpid ne 0 && $waitpid ne -1) {
            $child_exit_code = $? >> 8;
          }
  
          if ($waitpid eq -1) {
            $child_finished = 1;
          }
  
          my $ready_fds = [];
          push @{$ready_fds}, $select->can_read(1/100);
  
          READY_FDS: while (scalar(@{$ready_fds})) {
            my $fd = shift @{$ready_fds};
            $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
  
            my $str = $child_output->{$fd->fileno};
            Carp::confess("child stream not found: $fd") unless $str;
  
            my $data = "";
            my $count = $fd->sysread($data, $str->{'block_size'});
  
            if ($count) {
                # extract all the available lines and store the rest in temporary buffer
                if ($data =~ /(.+\n)([^\n]*)/so) {
                    $data = $str->{'scalar_buffer'} . $1;
                    $str->{'scalar_buffer'} = $2 || "";
                }
                else {
                    $str->{'scalar_buffer'} .= $data;
                    $data = "";
                }
            }
            elsif ($count eq 0) {
              $select->remove($fd);
              $fd->close();
              if ($str->{'scalar_buffer'}) {
                  $data = $str->{'scalar_buffer'} . "\n";
              }
            }
            else {
              Carp::confess("error during sysread on [$fd]: " . $!);
            }
  
            # $data contains only full lines (or last line if it was unfinished read
            # or now new-line in the output of the child); dat is processed
            # according to the "protocol" of socket
            if ($str->{'protocol'} eq 'info') {
              if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) {
                $child_child_pid = $1;
                $data = $2;
              }
              if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) {
                $child_child_pid = undef;
                $data = $2;
              }
              if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
                $child_killed_by_signal = $1;
                $data = $2;
              }
  
              # we don't expect any other data in info socket, so it's
              # some strange violation of protocol, better know about this
              if ($data) {
                Carp::confess("info protocol violation: [$data]");
              }
            }
            if ($str->{'protocol'} eq 'stdout') {
              if (!$opts->{'discard_output'}) {
                $child_stdout .= $data;
                $child_merged .= $data;
              }
  
              if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
                $opts->{'stdout_handler'}->($data);
              }
            }
            if ($str->{'protocol'} eq 'stderr') {
              if (!$opts->{'discard_output'}) {
                $child_stderr .= $data;
                $child_merged .= $data;
              }
  
              if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
                $opts->{'stderr_handler'}->($data);
              }
            }
   
            # process may finish (waitpid returns -1) before
            # we've read all of its output because of buffering;
            # so try to read all the way it is possible to read
            # in such case - this shouldn't be too much (unless
            # the buffer size is HUGE -- should introduce
            # another counter in such case, maybe later)
            #
            push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
          }
  
          if ($opts->{'wait_loop_callback'} && ref($opts->{'wait_loop_callback'}) eq 'CODE') {
            $opts->{'wait_loop_callback'}->();
          }
  
          Time::HiRes::usleep(1);
        }
  
        # $child_pid_pid is not defined in two cases:
        #  * when our child was killed before
        #    it had chance to tell us the pid
        #    of the child it spawned. we can do
        #    nothing in this case :(
        #  * our child successfully reaped its child,
        #    we have nothing left to do in this case
        #
        # defined $child_pid_pid means child's child
        # has not died but nobody is waiting for it,
        # killing it brutally.
        #
        if ($child_child_pid) {
          kill_gently($child_child_pid);
        }
  
        # in case there are forks in child which
        # do not forward or process signals (TERM) correctly
        # kill whole child process group, effectively trying
        # not to return with some children or their parts still running
        #
        # to be more accurate -- we need to be sure
        # that this is process group created by our child
        # (and not some other process group with the same pgid,
        # created just after death of our child) -- fortunately
        # this might happen only when process group ids
        # are reused quickly (there are lots of processes
        # spawning new process groups for example)
        #
        if ($opts->{'clean_up_children'}) {
          kill(-9, $pid);
        }
  
    #    print "child $pid finished\n";
  
        close($child_stdout_socket);
        close($child_stderr_socket);
        close($child_info_socket);
  
        my $o = {
          'stdout' => $child_stdout,
          'stderr' => $child_stderr,
          'merged' => $child_merged,
          'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
          'exit_code' => $child_exit_code,
          'parent_died' => $parent_died,
          'killed_by_signal' => $child_killed_by_signal,
          'child_pgid' => $pid,
          'cmd' => $cmd,
          };
  
        my $err_msg = '';
        if ($o->{'exit_code'}) {
          $err_msg .= "exited with code [$o->{'exit_code'}]\n";
        }
        if ($o->{'timeout'}) {
          $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
        }
        if ($o->{'parent_died'}) {
          $err_msg .= "parent died\n";
        }
        if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) {
          $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
        }
        if ($o->{'stderr'}) {
          $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
        }
        if ($o->{'killed_by_signal'}) {
          $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
        }
        $o->{'err_msg'} = $err_msg;
  
        if ($orig_sig_child) {
          $SIG{'CHLD'} = $orig_sig_child;
        }
        else {
          delete($SIG{'CHLD'});
        }
  
        uninstall_signals();
  
        return $o;
      }
      else {
        Carp::confess("cannot fork: $!") unless defined($pid);
  
        # create new process session for open3 call,
        # so we hopefully can kill all the subprocesses
        # which might be spawned in it (except for those
        # which do setsid theirselves -- can't do anything
        # with those)
  
        POSIX::setsid() || Carp::confess("Error running setsid: " . $!);
  
        if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
          $opts->{'child_BEGIN'}->();
        }
  
        close($child_stdout_socket);
        close($child_stderr_socket);
        close($child_info_socket);
  
        my $child_exit_code;
  
        # allow both external programs
        # and internal perl calls
        if (!ref($cmd)) {
          $child_exit_code = open3_run($cmd, {
            'parent_info' => $parent_info_socket,
            'parent_stdout' => $parent_stdout_socket,
            'parent_stderr' => $parent_stderr_socket,
            'child_stdin' => $opts->{'child_stdin'},
            });
        }
        elsif (ref($cmd) eq 'CODE') {
          # reopen STDOUT and STDERR for child code:
          # https://rt.cpan.org/Ticket/Display.html?id=85912
          open STDOUT, '>&', $parent_stdout_socket || Carp::confess("Unable to reopen STDOUT: $!\n");
          open STDERR, '>&', $parent_stderr_socket || Carp::confess("Unable to reopen STDERR: $!\n");
  
          $child_exit_code = $cmd->({
            'opts' => $opts,
            'parent_info' => $parent_info_socket,
            'parent_stdout' => $parent_stdout_socket,
            'parent_stderr' => $parent_stderr_socket,
            'child_stdin' => $opts->{'child_stdin'},
            });
        }
        else {
          print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
          $child_exit_code = 1;
        }
  
        close($parent_stdout_socket);
        close($parent_stderr_socket);
        close($parent_info_socket);
  
        if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
          $opts->{'child_END'}->();
        }
  
        $| = 1;
        POSIX::_exit $child_exit_code;
      }
  }
  
  sub run {
      ### container to store things in
      my $self = bless {}, __PACKAGE__;
  
      my %hash = @_;
  
      ### if the user didn't provide a buffer, we'll store it here.
      my $def_buf = '';
  
      my($verbose,$cmd,$buffer,$timeout);
      my $tmpl = {
          verbose => { default  => $VERBOSE,  store => \$verbose },
          buffer  => { default  => \$def_buf, store => \$buffer },
          command => { required => 1,         store => \$cmd,
                       allow    => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
          },
          timeout => { default  => 0,         store => \$timeout },
      };
  
      unless( check( $tmpl, \%hash, $VERBOSE ) ) {
          Carp::carp( loc( "Could not validate input: %1",
                           Params::Check->last_error ) );
          return;
      };
  
      $cmd = _quote_args_vms( $cmd ) if IS_VMS;
  
      ### strip any empty elements from $cmd if present
      if ( $ALLOW_NULL_ARGS ) {
        $cmd = [ grep { defined } @$cmd ] if ref $cmd;
      }
      else {
        $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
      }
  
      my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
      print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
  
      ### did the user pass us a buffer to fill or not? if so, set this
      ### flag so we know what is expected of us
      ### XXX this is now being ignored. in the future, we could add diagnostic
      ### messages based on this logic
      #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
  
      ### buffers that are to be captured
      my( @buffer, @buff_err, @buff_out );
  
      ### capture STDOUT
      my $_out_handler = sub {
          my $buf = shift;
          return unless defined $buf;
  
          print STDOUT $buf if $verbose;
          push @buffer,   $buf;
          push @buff_out, $buf;
      };
  
      ### capture STDERR
      my $_err_handler = sub {
          my $buf = shift;
          return unless defined $buf;
  
          print STDERR $buf if $verbose;
          push @buffer,   $buf;
          push @buff_err, $buf;
      };
  
  
      ### flag to indicate we have a buffer captured
      my $have_buffer = $self->can_capture_buffer ? 1 : 0;
  
      ### flag indicating if the subcall went ok
      my $ok;
  
      ### don't look at previous errors:
      local $?;
      local $@;
      local $!;
  
      ### we might be having a timeout set
      eval {
          local $SIG{ALRM} = sub { die bless sub {
              ALARM_CLASS .
              qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
          }, ALARM_CLASS } if $timeout;
          alarm $timeout || 0;
  
          ### IPC::Run is first choice if $USE_IPC_RUN is set.
          if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
              ### ipc::run handlers needs the command as a string or an array ref
  
              $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
                  if $DEBUG;
  
              $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
  
          ### since IPC::Open3 works on all platforms, and just fails on
          ### win32 for capturing buffers, do that ideally
          } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
  
              $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
                  if $DEBUG;
  
              ### in case there are pipes in there;
              ### IPC::Open3 will call exec and exec will do the right thing
  
              my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run';
  
              $ok = $self->$method(
                                      $cmd, $_out_handler, $_err_handler, $verbose
                                  );
  
          ### if we are allowed to run verbose, just dispatch the system command
          } else {
              $self->_debug( "# Using system(). Have buffer: $have_buffer" )
                  if $DEBUG;
              $ok = $self->_system_run( $cmd, $verbose );
          }
  
          alarm 0;
      };
  
      ### restore STDIN after duping, or STDIN will be closed for
      ### this current perl process!
      $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
  
      my $err;
      unless( $ok ) {
          ### alarm happened
          if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
              $err = $@->();  # the error code is an expired alarm
  
          ### another error happened, set by the dispatchub
          } else {
              $err = $self->error;
          }
      }
  
      ### fill the buffer;
      $$buffer = join '', @buffer if @buffer;
  
      ### return a list of flags and buffers (if available) in list
      ### context, or just a simple 'ok' in scalar
      return wantarray
                  ? $have_buffer
                      ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
                      : ($ok, $err )
                  : $ok
  
  
  }
  
  sub _open3_run_win32 {
    my $self    = shift;
    my $cmd     = shift;
    my $outhand = shift;
    my $errhand = shift;
  
    require Socket;
  
    my $pipe = sub {
      socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC)
          or return undef;
      shutdown($_[0], 1);  # No more writing for reader
      shutdown($_[1], 0);  # No more reading for writer
      return 1;
    };
  
    my $open3 = sub {
      local (*TO_CHLD_R,     *TO_CHLD_W);
      local (*FR_CHLD_R,     *FR_CHLD_W);
      local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);
  
      $pipe->(*TO_CHLD_R,     *TO_CHLD_W    ) or die $^E;
      $pipe->(*FR_CHLD_R,     *FR_CHLD_W    ) or die $^E;
      $pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;
  
      my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);
  
      return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
    };
  
    $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
    $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
  
    my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
      $open3->( ( ref $cmd ? @$cmd : $cmd ) );
  
    my $in_sel  = IO::Select->new();
    my $out_sel = IO::Select->new();
  
    my %objs;
  
    $objs{ fileno( $fr_chld ) } = $outhand;
    $objs{ fileno( $fr_chld_err ) } = $errhand;
    $in_sel->add( $fr_chld );
    $in_sel->add( $fr_chld_err );
  
    close($to_chld);
  
    while ($in_sel->count() + $out_sel->count()) {
      my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
  
      for my $fh (@$ins) {
          my $obj = $objs{ fileno($fh) };
          my $buf;
          my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
          if (!$bytes_read) {
              $in_sel->remove($fh);
          }
          else {
              $obj->( "$buf" );
          }
        }
  
        for my $fh (@$outs) {
        }
    }
  
    waitpid($pid, 0);
  
    ### some error occurred
    if( $? ) {
          $self->error( $self->_pp_child_error( $cmd, $? ) );
          $self->ok( 0 );
          return;
    } else {
          return $self->ok( 1 );
    }
  }
  
  sub _open3_run {
      my $self            = shift;
      my $cmd             = shift;
      my $_out_handler    = shift;
      my $_err_handler    = shift;
      my $verbose         = shift || 0;
  
      ### Following code are adapted from Friar 'abstracts' in the
      ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
      ### XXX that code didn't work.
      ### we now use the following code, thanks to theorbtwo
  
      ### define them beforehand, so we always have defined FH's
      ### to read from.
      use Symbol;
      my $kidout      = Symbol::gensym();
      my $kiderror    = Symbol::gensym();
  
      ### Dup the filehandle so we can pass 'our' STDIN to the
      ### child process. This stops us from having to pump input
      ### from ourselves to the childprocess. However, we will need
      ### to revive the FH afterwards, as IPC::Open3 closes it.
      ### We'll do the same for STDOUT and STDERR. It works without
      ### duping them on non-unix derivatives, but not on win32.
      my @fds_to_dup = ( IS_WIN32 && !$verbose
                              ? qw[STDIN STDOUT STDERR]
                              : qw[STDIN]
                          );
      $self->_fds( \@fds_to_dup );
      $self->__dup_fds( @fds_to_dup );
  
      ### pipes have to come in a quoted string, and that clashes with
      ### whitespace. This sub fixes up such commands so they run properly
      $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
  
      ### don't stringify @$cmd, so spaces in filenames/paths are
      ### treated properly
      my $pid = eval {
          IPC::Open3::open3(
                      '<&STDIN',
                      (IS_WIN32 ? '>&STDOUT' : $kidout),
                      (IS_WIN32 ? '>&STDERR' : $kiderror),
                      ( ref $cmd ? @$cmd : $cmd ),
                  );
      };
  
      ### open3 error occurred
      if( $@ and $@ =~ /^open3:/ ) {
          $self->ok( 0 );
          $self->error( $@ );
          return;
      };
  
      ### use OUR stdin, not $kidin. Somehow,
      ### we never get the input.. so jump through
      ### some hoops to do it :(
      my $selector = IO::Select->new(
                          (IS_WIN32 ? \*STDERR : $kiderror),
                          \*STDIN,
                          (IS_WIN32 ? \*STDOUT : $kidout)
                      );
  
      STDOUT->autoflush(1);   STDERR->autoflush(1);   STDIN->autoflush(1);
      $kidout->autoflush(1)   if UNIVERSAL::can($kidout,   'autoflush');
      $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
  
      ### add an explicit break statement
      ### code courtesy of theorbtwo from #london.pm
      my $stdout_done = 0;
      my $stderr_done = 0;
      OUTER: while ( my @ready = $selector->can_read ) {
  
          for my $h ( @ready ) {
              my $buf;
  
              ### $len is the amount of bytes read
              my $len = sysread( $h, $buf, 4096 );    # try to read 4096 bytes
  
              ### see perldoc -f sysread: it returns undef on error,
              ### so bail out.
              if( not defined $len ) {
                  warn(loc("Error reading from process: %1", $!));
                  last OUTER;
              }
  
              ### check for $len. it may be 0, at which point we're
              ### done reading, so don't try to process it.
              ### if we would print anyway, we'd provide bogus information
              $_out_handler->( "$buf" ) if $len && $h == $kidout;
              $_err_handler->( "$buf" ) if $len && $h == $kiderror;
  
              ### Wait till child process is done printing to both
              ### stdout and stderr.
              $stdout_done = 1 if $h == $kidout   and $len == 0;
              $stderr_done = 1 if $h == $kiderror and $len == 0;
              last OUTER if ($stdout_done && $stderr_done);
          }
      }
  
      waitpid $pid, 0; # wait for it to die
  
      ### restore STDIN after duping, or STDIN will be closed for
      ### this current perl process!
      ### done in the parent call now
      # $self->__reopen_fds( @fds_to_dup );
  
      ### some error occurred
      if( $? ) {
          $self->error( $self->_pp_child_error( $cmd, $? ) );
          $self->ok( 0 );
          return;
      } else {
          return $self->ok( 1 );
      }
  }
  
  ### Text::ParseWords::shellwords() uses unix semantics. that will break
  ### on win32
  {   my $parse_sub = IS_WIN32
                          ? __PACKAGE__->can('_split_like_shell_win32')
                          : Text::ParseWords->can('shellwords');
  
      sub _ipc_run {
          my $self            = shift;
          my $cmd             = shift;
          my $_out_handler    = shift;
          my $_err_handler    = shift;
  
          STDOUT->autoflush(1); STDERR->autoflush(1);
  
          ### a command like:
          # [
          #     '/usr/bin/gzip',
          #     '-cdf',
          #     '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
          #     '|',
          #     '/usr/bin/tar',
          #     '-tf -'
          # ]
          ### needs to become:
          # [
          #     ['/usr/bin/gzip', '-cdf',
          #       '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
          #     '|',
          #     ['/usr/bin/tar', '-tf -']
          # ]
  
  
          my @command;
          my $special_chars;
  
          my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
          if( ref $cmd ) {
              my $aref = [];
              for my $item (@$cmd) {
                  if( $item =~ $re ) {
                      push @command, $aref, $item;
                      $aref = [];
                      $special_chars .= $1;
                  } else {
                      push @$aref, $item;
                  }
              }
              push @command, $aref;
          } else {
              @command = map { if( $_ =~ $re ) {
                                  $special_chars .= $1; $_;
                               } else {
  #                                [ split /\s+/ ]
                                   [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
                               }
                          } split( /\s*$re\s*/, $cmd );
          }
  
          ### if there's a pipe in the command, *STDIN needs to
          ### be inserted *BEFORE* the pipe, to work on win32
          ### this also works on *nix, so we should do it when possible
          ### this should *also* work on multiple pipes in the command
          ### if there's no pipe in the command, append STDIN to the back
          ### of the command instead.
          ### XXX seems IPC::Run works it out for itself if you just
          ### don't pass STDIN at all.
          #     if( $special_chars and $special_chars =~ /\|/ ) {
          #         ### only add STDIN the first time..
          #         my $i;
          #         @command = map { ($_ eq '|' && not $i++)
          #                             ? ( \*STDIN, $_ )
          #                             : $_
          #                         } @command;
          #     } else {
          #         push @command, \*STDIN;
          #     }
  
          # \*STDIN is already included in the @command, see a few lines up
          my $ok = eval { IPC::Run::run(   @command,
                                  fileno(STDOUT).'>',
                                  $_out_handler,
                                  fileno(STDERR).'>',
                                  $_err_handler
                              )
                          };
  
          ### all is well
          if( $ok ) {
              return $self->ok( $ok );
  
          ### some error occurred
          } else {
              $self->ok( 0 );
  
              ### if the eval fails due to an exception, deal with it
              ### unless it's an alarm
              if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
                  $self->error( $@ );
  
              ### if it *is* an alarm, propagate
              } elsif( $@ ) {
                  die $@;
  
              ### some error in the sub command
              } else {
                  $self->error( $self->_pp_child_error( $cmd, $? ) );
              }
  
              return;
          }
      }
  }
  
  sub _system_run {
      my $self    = shift;
      my $cmd     = shift;
      my $verbose = shift || 0;
  
      ### pipes have to come in a quoted string, and that clashes with
      ### whitespace. This sub fixes up such commands so they run properly
      $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
  
      my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
      $self->_fds( \@fds_to_dup );
      $self->__dup_fds( @fds_to_dup );
  
      ### system returns 'true' on failure -- the exit code of the cmd
      $self->ok( 1 );
      system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
          $self->error( $self->_pp_child_error( $cmd, $? ) );
          $self->ok( 0 );
      };
  
      ### done in the parent call now
      #$self->__reopen_fds( @fds_to_dup );
  
      return unless $self->ok;
      return $self->ok;
  }
  
  {   my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
  
  
      sub __fix_cmd_whitespace_and_special_chars {
          my $self = shift;
          my $cmd  = shift;
  
          ### command has a special char in it
          if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
  
              ### since we have special chars, we have to quote white space
              ### this *may* conflict with the parsing :(
              my $fixed;
              my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
  
              $self->_debug( "# Quoted $fixed arguments containing whitespace" )
                      if $DEBUG && $fixed;
  
              ### stringify it, so the special char isn't escaped as argument
              ### to the program
              $cmd = join ' ', @cmd;
          }
  
          return $cmd;
      }
  }
  
  ### Command-line arguments (but not the command itself) must be quoted
  ### to ensure case preservation. Borrowed from Module::Build with adaptations.
  ### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
  ### quoting for run() on VMS
  sub _quote_args_vms {
    ### Returns a command string with proper quoting so that the subprocess
    ### sees this same list of args, or if we get a single arg that is an
    ### array reference, quote the elements of it (except for the first)
    ### and return the reference.
    my @args = @_;
    my $got_arrayref = (scalar(@args) == 1
                        && UNIVERSAL::isa($args[0], 'ARRAY'))
                     ? 1
                     : 0;
  
    @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
  
    my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
  
    ### Do not quote qualifiers that begin with '/' or previously quoted args.
    map { if (/^[^\/\"]/) {
            $_ =~ s/\"/""/g;     # escape C<"> by doubling
            $_ = q(").$_.q(");
          }
    }
      ($got_arrayref ? @{$args[0]}
                     : @args
      );
  
    $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
  
    return $got_arrayref ? $args[0]
                         : join(' ', @args);
  }
  
  
  ### XXX this is cribbed STRAIGHT from M::B 0.30 here:
  ### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
  ### XXX this *should* be integrated into text::parsewords
  sub _split_like_shell_win32 {
    # As it turns out, Windows command-parsing is very different from
    # Unix command-parsing.  Double-quotes mean different things,
    # backslashes don't necessarily mean escapes, and so on.  So we
    # can't use Text::ParseWords::shellwords() to break a command string
    # into words.  The algorithm below was bashed out by Randy and Ken
    # (mostly Randy), and there are a lot of regression tests, so we
    # should feel free to adjust if desired.
  
    local $_ = shift;
  
    my @argv;
    return @argv unless defined() && length();
  
    my $arg = '';
    my( $i, $quote_mode ) = ( 0, 0 );
  
    while ( $i < length() ) {
  
      my $ch      = substr( $_, $i  , 1 );
      my $next_ch = substr( $_, $i+1, 1 );
  
      if ( $ch eq '\\' && $next_ch eq '"' ) {
        $arg .= '"';
        $i++;
      } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
        $arg .= '\\';
        $i++;
      } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
        $quote_mode = !$quote_mode;
        $arg .= '"';
        $i++;
      } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
            ( $i + 2 == length()  ||
          substr( $_, $i + 2, 1 ) eq ' ' )
          ) { # for cases like: a"" => [ 'a' ]
        push( @argv, $arg );
        $arg = '';
        $i += 2;
      } elsif ( $ch eq '"' ) {
        $quote_mode = !$quote_mode;
      } elsif ( $ch eq ' ' && !$quote_mode ) {
        push( @argv, $arg ) if defined( $arg ) && length( $arg );
        $arg = '';
        ++$i while substr( $_, $i + 1, 1 ) eq ' ';
      } else {
        $arg .= $ch;
      }
  
      $i++;
    }
  
    push( @argv, $arg ) if defined( $arg ) && length( $arg );
    return @argv;
  }
  
  
  
  {   use File::Spec;
      use Symbol;
  
      my %Map = (
          STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
          STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
          STDIN  => [qw|<&|, \*STDIN,  Symbol::gensym() ],
      );
  
      ### dups FDs and stores them in a cache
      sub __dup_fds {
          my $self    = shift;
          my @fds     = @_;
  
          __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
  
          for my $name ( @fds ) {
              my($redir, $fh, $glob) = @{$Map{$name}} or (
                  Carp::carp(loc("No such FD: '%1'", $name)), next );
  
              ### MUST use the 2-arg version of open for dup'ing for
              ### 5.6.x compatibility. 5.8.x can use 3-arg open
              ### see perldoc5.6.2 -f open for details
              open $glob, $redir . fileno($fh) or (
                          Carp::carp(loc("Could not dup '$name': %1", $!)),
                          return
                      );
  
              ### we should re-open this filehandle right now, not
              ### just dup it
              ### Use 2-arg version of open, as 5.5.x doesn't support
              ### 3-arg version =/
              if( $redir eq '>&' ) {
                  open( $fh, '>' . File::Spec->devnull ) or (
                      Carp::carp(loc("Could not reopen '$name': %1", $!)),
                      return
                  );
              }
          }
  
          return 1;
      }
  
      ### reopens FDs from the cache
      sub __reopen_fds {
          my $self    = shift;
          my @fds     = @_;
  
          __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
  
          for my $name ( @fds ) {
              my($redir, $fh, $glob) = @{$Map{$name}} or (
                  Carp::carp(loc("No such FD: '%1'", $name)), next );
  
              ### MUST use the 2-arg version of open for dup'ing for
              ### 5.6.x compatibility. 5.8.x can use 3-arg open
              ### see perldoc5.6.2 -f open for details
              open( $fh, $redir . fileno($glob) ) or (
                      Carp::carp(loc("Could not restore '$name': %1", $!)),
                      return
                  );
  
              ### close this FD, we're not using it anymore
              close $glob;
          }
          return 1;
  
      }
  }
  
  sub _debug {
      my $self    = shift;
      my $msg     = shift or return;
      my $level   = shift || 0;
  
      local $Carp::CarpLevel += $level;
      Carp::carp($msg);
  
      return 1;
  }
  
  sub _pp_child_error {
      my $self    = shift;
      my $cmd     = shift or return;
      my $ce      = shift or return;
      my $pp_cmd  = ref $cmd ? "@$cmd" : $cmd;
  
  
      my $str;
      if( $ce == -1 ) {
          ### Include $! in the error message, so that the user can
          ### see 'No such file or directory' versus 'Permission denied'
          ### versus 'Cannot fork' or whatever the cause was.
          $str = "Failed to execute '$pp_cmd': $!";
  
      } elsif ( $ce & 127 ) {
          ### some signal
          $str = loc( "'%1' died with signal %2, %3 coredump",
                 $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
  
      } else {
          ### Otherwise, the command run but gave error status.
          $str = "'$pp_cmd' exited with value " . ($ce >> 8);
      }
  
      $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
  
      return $str;
  }
  
  1;
  
  __END__
  
  =head2 $q = QUOTE
  
  Returns the character used for quoting strings on this platform. This is
  usually a C<'> (single quote) on most systems, but some systems use different
  quotes. For example, C<Win32> uses C<"> (double quote).
  
  You can use it as follows:
  
    use IPC::Cmd qw[run QUOTE];
    my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
  
  This makes sure that C<foo bar> is treated as a string, rather than two
  separate arguments to the C<echo> function.
  
  =head1 HOW IT WORKS
  
  C<run> will try to execute your command using the following logic:
  
  =over 4
  
  =item *
  
  If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
  is set to true (See the L<"Global Variables"> section) use that to execute
  the command. You will have the full output available in buffers, interactive commands
  are sure to work  and you are guaranteed to have your verbosity
  settings honored cleanly.
  
  =item *
  
  Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
  (See the L<"Global Variables"> section), try to execute the command using
  L<IPC::Open3>. Buffers will be available on all platforms,
  interactive commands will still execute cleanly, and also your verbosity
  settings will be adhered to nicely;
  
  =item *
  
  Otherwise, if you have the C<verbose> argument set to true, we fall back
  to a simple C<system()> call. We cannot capture any buffers, but
  interactive commands will still work.
  
  =item *
  
  Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
  C<system()> call with your command and then re-open STDERR and STDOUT.
  This is the method of last resort and will still allow you to execute
  your commands cleanly. However, no buffers will be available.
  
  =back
  
  =head1 Global Variables
  
  The behaviour of IPC::Cmd can be altered by changing the following
  global variables:
  
  =head2 $IPC::Cmd::VERBOSE
  
  This controls whether IPC::Cmd will print any output from the
  commands to the screen or not. The default is 0.
  
  =head2 $IPC::Cmd::USE_IPC_RUN
  
  This variable controls whether IPC::Cmd will try to use L<IPC::Run>
  when available and suitable.
  
  =head2 $IPC::Cmd::USE_IPC_OPEN3
  
  This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
  when available and suitable. Defaults to true.
  
  =head2 $IPC::Cmd::WARN
  
  This variable controls whether run-time warnings should be issued, like
  the failure to load an C<IPC::*> module you explicitly requested.
  
  Defaults to true. Turn this off at your own risk.
  
  =head2 $IPC::Cmd::INSTANCES
  
  This variable controls whether C<can_run> will return all instances of
  the binary it finds in the C<PATH> when called in a list context.
  
  Defaults to false, set to true to enable the described behaviour.
  
  =head2 $IPC::Cmd::ALLOW_NULL_ARGS
  
  This variable controls whether C<run> will remove any empty/null arguments
  it finds in command arguments.
  
  Defaults to false, so it will remove null arguments. Set to true to allow
  them.
  
  =head1 Caveats
  
  =over 4
  
  =item Whitespace and IPC::Open3 / system()
  
  When using C<IPC::Open3> or C<system>, if you provide a string as the
  C<command> argument, it is assumed to be appropriately escaped. You can
  use the C<QUOTE> constant to use as a portable quote character (see above).
  However, if you provide an array reference, special rules apply:
  
  If your command contains B<special characters> (< > | &), it will
  be internally stringified before executing the command, to avoid that these
  special characters are escaped and passed as arguments instead of retaining
  their special meaning.
  
  However, if the command contained arguments that contained whitespace,
  stringifying the command would lose the significance of the whitespace.
  Therefore, C<IPC::Cmd> will quote any arguments containing whitespace in your
  command if the command is passed as an arrayref and contains special characters.
  
  =item Whitespace and IPC::Run
  
  When using C<IPC::Run>, if you provide a string as the C<command> argument,
  the string will be split on whitespace to determine the individual elements
  of your command. Although this will usually just Do What You Mean, it may
  break if you have files or commands with whitespace in them.
  
  If you do not wish this to happen, you should provide an array
  reference, where all parts of your command are already separated out.
  Note however, if there are extra or spurious whitespaces in these parts,
  the parser or underlying code may not interpret it correctly, and
  cause an error.
  
  Example:
  The following code
  
      gzip -cdf foo.tar.gz | tar -xf -
  
  should either be passed as
  
      "gzip -cdf foo.tar.gz | tar -xf -"
  
  or as
  
      ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
  
  But take care not to pass it as, for example
  
      ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
  
  Since this will lead to issues as described above.
  
  
  =item IO Redirect
  
  Currently it is too complicated to parse your command for IO
  redirections. For capturing STDOUT or STDERR there is a work around
  however, since you can just inspect your buffers for the contents.
  
  =item Interleaving STDOUT/STDERR
  
  Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
  bursts of output from a program, e.g. this sample,
  
      for ( 1..4 ) {
          $_ % 2 ? print STDOUT $_ : print STDERR $_;
      }
  
  IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
  the output looks like '13' on STDOUT and '24' on STDERR, instead of
  
      1
      2
      3
      4
  
  This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
  STDOUT and STDERR.
  
  =back
  
  =head1 See Also
  
  L<IPC::Run>, L<IPC::Open3>
  
  =head1 ACKNOWLEDGEMENTS
  
  Thanks to James Mastros and Martijn van der Streek for their
  help in getting L<IPC::Open3> to behave nicely.
  
  Thanks to Petya Kohts for the C<run_forked> code.
  
  =head1 BUG REPORTS
  
  Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
  
  =head1 AUTHOR
  
  Original author: Jos Boumans E<lt>kane@cpan.orgE<gt>.
  Current maintainer: Chris Williams E<lt>bingos@cpan.orgE<gt>.
  
  =head1 COPYRIGHT
  
  This library is free software; you may redistribute and/or modify it
  under the same terms as Perl itself.
  
  =cut
IPC_CMD

$fatpacked{"IPC/Run3.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3';
  package IPC::Run3;
  BEGIN { require 5.006_000; } # i.e. 5.6.0
  use strict;
  
  =head1 NAME
  
  IPC::Run3 - run a subprocess with input/ouput redirection
  
  =head1 VERSION
  
  version 0.048
  
  =cut
  
  our $VERSION = '0.048';
  
  =head1 SYNOPSIS
  
      use IPC::Run3;    # Exports run3() by default
  
      run3 \@cmd, \$in, \$out, \$err;
  
  =head1 DESCRIPTION
  
  This module allows you to run a subprocess and redirect stdin, stdout,
  and/or stderr to files and perl data structures.  It aims to satisfy 99% of the
  need for using C<system>, C<qx>, and C<open3>
  with a simple, extremely Perlish API.
  
  Speed, simplicity, and portability are paramount.  (That's speed of Perl code;
  which is often much slower than the kind of buffered I/O that this module uses
  to spool input to and output from the child command.)
  
  =cut
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT = qw( run3 );
  our %EXPORT_TAGS = ( all => \@EXPORT );
  
  use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
  use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
  use constant is_win32  => 0 <= index $^O, "Win32";
  
  BEGIN {
     if ( is_win32 ) {
        eval "use Win32 qw( GetOSName ); use Win32::ShellQuote qw(quote_native); 1" or die $@;
     }
  }
  
  #use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
  #use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;
  
  use Carp qw( croak );
  use File::Temp qw( tempfile );
  use POSIX qw( dup dup2 );
  
  # We cache the handles of our temp files in order to
  # keep from having to incur the (largish) overhead of File::Temp
  my %fh_cache;
  my $fh_cache_pid = $$;
  
  my $profiler;
  
  sub _profiler { $profiler } # test suite access
  
  BEGIN {
      if ( profiling ) {
          eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
          if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
              require IPC::Run3::ProfPP;
              IPC::Run3::ProfPP->import;
              $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
          } else {
              my ( $dest, undef, $class ) =
                 reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
              $class = "IPC::Run3::ProfLogger"
                  unless defined $class && length $class;
              if ( not eval "require $class" ) {
                  my $e = $@;
                  $class = "IPC::Run3::$class";
                  eval "require IPC::Run3::$class" or die $e;
              }
              $profiler = $class->new( Destination => $dest );
          }
          $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
      }
  }
  
  
  END {
      $profiler->app_exit( scalar gettimeofday() ) if profiling;
  }
  
  sub _binmode {
      my ( $fh, $mode, $what ) = @_;
      # if $mode is not given, then default to ":raw", except on Windows,
      # where we default to ":crlf";
      # otherwise if a proper layer string was given, use that,
      # else use ":raw"
      my $layer = !$mode
         ? (is_win32 ? ":crlf" : ":raw")
         : ($mode =~ /^:/ ? $mode : ":raw");
      warn "binmode $what, $layer\n" if debugging >= 2;
  
      binmode $fh, ":raw" unless $layer eq ":raw";      # remove all layers first
      binmode $fh, $layer or croak "binmode $layer failed: $!";
  }
  
  sub _spool_data_to_child {
      my ( $type, $source, $binmode_it ) = @_;
  
      # If undef (not \undef) passed, they want the child to inherit
      # the parent's STDIN.
      return undef unless defined $source;
  
      my $fh;
      if ( ! $type ) {
          open $fh, "<", $source or croak "$!: $source";
         _binmode($fh, $binmode_it, "STDIN");
          warn "run3(): feeding file '$source' to child STDIN\n"
              if debugging >= 2;
      } elsif ( $type eq "FH" ) {
          $fh = $source;
          warn "run3(): feeding filehandle '$source' to child STDIN\n"
              if debugging >= 2;
      } else {
          $fh = $fh_cache{in} ||= tempfile;
          truncate $fh, 0;
          seek $fh, 0, 0;
         _binmode($fh, $binmode_it, "STDIN");
          my $seekit;
          if ( $type eq "SCALAR" ) {
  
              # When the run3()'s caller asks to feed an empty file
              # to the child's stdin, we want to pass a live file
              # descriptor to an empty file (like /dev/null) so that
              # they don't get surprised by invalid fd errors and get
              # normal EOF behaviors.
              return $fh unless defined $$source;  # \undef passed
  
              warn "run3(): feeding SCALAR to child STDIN",
                  debugging >= 3
                     ? ( ": '", $$source, "' (", length $$source, " chars)" )
                     : (),
                  "\n"
                  if debugging >= 2;
  
              $seekit = length $$source;
              print $fh $$source or die "$! writing to temp file";
  
          } elsif ( $type eq "ARRAY" ) {
              warn "run3(): feeding ARRAY to child STDIN",
                  debugging >= 3 ? ( ": '", @$source, "'" ) : (),
                  "\n"
              if debugging >= 2;
  
              print $fh @$source or die "$! writing to temp file";
              $seekit = grep length, @$source;
          } elsif ( $type eq "CODE" ) {
              warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
                  if debugging >= 2;
              my $parms = [];  # TODO: get these from $options
              while (1) {
                  my $data = $source->( @$parms );
                  last unless defined $data;
                  print $fh $data or die "$! writing to temp file";
                  $seekit = length $data;
              }
          }
  
          seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
              if $seekit;
      }
  
      croak "run3() can't redirect $type to child stdin"
          unless defined $fh;
  
      return $fh;
  }
  
  sub _fh_for_child_output {
      my ( $what, $type, $dest, $options ) = @_;
  
      my $fh;
      if ( $type eq "SCALAR" && $dest == \undef ) {
          warn "run3(): redirecting child $what to oblivion\n"
              if debugging >= 2;
  
          $fh = $fh_cache{nul} ||= do {
              open $fh, ">", File::Spec->devnull;
             $fh;
          };
      } elsif ( $type eq "FH" ) {
          $fh = $dest;
          warn "run3(): redirecting $what to filehandle '$dest'\n"
              if debugging >= 3;
      } elsif ( !$type ) {
          warn "run3(): feeding child $what to file '$dest'\n"
              if debugging >= 2;
  
          open $fh, $options->{"append_$what"} ? ">>" : ">", $dest
             or croak "$!: $dest";
      } else {
          warn "run3(): capturing child $what\n"
              if debugging >= 2;
  
          $fh = $fh_cache{$what} ||= tempfile;
          seek $fh, 0, 0;
          truncate $fh, 0;
      }
  
      my $binmode_it = $options->{"binmode_$what"};
      _binmode($fh, $binmode_it, uc $what);
  
      return $fh;
  }
  
  sub _read_child_output_fh {
      my ( $what, $type, $dest, $fh, $options ) = @_;
  
      return if $type eq "SCALAR" && $dest == \undef;
  
      seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";
  
      if ( $type eq "SCALAR" ) {
          warn "run3(): reading child $what to SCALAR\n"
              if debugging >= 3;
  
          # two read()s are used instead of 1 so that the first will be
          # logged even it reads 0 bytes; the second won't.
          my $count = read $fh, $$dest, 10_000,
             $options->{"append_$what"} ? length $$dest : 0;
          while (1) {
              croak "$! reading child $what from temp file"
                  unless defined $count;
  
              last unless $count;
  
              warn "run3(): read $count bytes from child $what",
                  debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
                  "\n"
                  if debugging >= 2;
  
              $count = read $fh, $$dest, 10_000, length $$dest;
          }
      } elsif ( $type eq "ARRAY" ) {
         if ($options->{"append_$what"}) {
             push @$dest, <$fh>;
         } else {
             @$dest = <$fh>;
         }
          if ( debugging >= 2 ) {
              my $count = 0;
              $count += length for @$dest;
              warn
                  "run3(): read ",
                  scalar @$dest,
                  " records, $count bytes from child $what",
                  debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
                  "\n";
          }
      } elsif ( $type eq "CODE" ) {
          warn "run3(): capturing child $what to CODE ref\n"
              if debugging >= 3;
  
          local $_;
          while ( <$fh> ) {
              warn
                  "run3(): read ",
                  length,
                  " bytes from child $what",
                  debugging >= 3 ? ( ": '", $_, "'" ) : (),
                  "\n"
                  if debugging >= 2;
  
              $dest->( $_ );
          }
      } else {
          croak "run3() can't redirect child $what to a $type";
      }
  
  }
  
  sub _type {
      my ( $redir ) = @_;
  
      return "FH" if eval {
          local $SIG{'__DIE__'};
          $redir->isa("IO::Handle")
      };
  
      my $type = ref $redir;
      return $type eq "GLOB" ? "FH" : $type;
  }
  
  sub _max_fd {
      my $fd = dup(0);
      POSIX::close $fd;
      return $fd;
  }
  
  my $run_call_time;
  my $sys_call_time;
  my $sys_exit_time;
  
  sub run3 {
      $run_call_time = gettimeofday() if profiling;
  
      my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};
  
      my ( $cmd, $stdin, $stdout, $stderr ) = @_;
  
      print STDERR "run3(): running ",
         join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
         "\n"
         if debugging;
  
      if ( ref $cmd ) {
          croak "run3(): empty command"     unless @$cmd;
          croak "run3(): undefined command" unless defined $cmd->[0];
          croak "run3(): command name ('')" unless length  $cmd->[0];
      } else {
          croak "run3(): missing command" unless @_;
          croak "run3(): undefined command" unless defined $cmd;
          croak "run3(): command ('')" unless length  $cmd;
      }
  
      foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) {
         if (my $mode = $options->{$_}) {
             croak qq[option $_ must be a number or a proper layer string: "$mode"]
                unless $mode =~ /^(:|\d+$)/;
         }
      }
  
      my $in_type  = _type $stdin;
      my $out_type = _type $stdout;
      my $err_type = _type $stderr;
  
      if ($fh_cache_pid != $$) {
         # fork detected, close all cached filehandles and clear the cache
         close $_ foreach values %fh_cache;
         %fh_cache = ();
         $fh_cache_pid = $$;
      }
  
      # This routine proceeds in stages so that a failure in an early
      # stage prevents later stages from running, and thus from needing
      # cleanup.
  
      my $in_fh  = _spool_data_to_child $in_type, $stdin,
          $options->{binmode_stdin} if defined $stdin;
  
      my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
          $options if defined $stdout;
  
      my $tie_err_to_out =
          defined $stderr && defined $stdout && $stderr eq $stdout;
  
      my $err_fh = $tie_err_to_out
          ? $out_fh
          : _fh_for_child_output "stderr", $err_type, $stderr,
              $options if defined $stderr;
  
      # this should make perl close these on exceptions
  #    local *STDIN_SAVE;
      local *STDOUT_SAVE;
      local *STDERR_SAVE;
  
      my $saved_fd0 = dup( 0 ) if defined $in_fh;
  
  #    open STDIN_SAVE,  "<&STDIN"#  or croak "run3(): $! saving STDIN"
  #        if defined $in_fh;
      open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
          if defined $out_fh;
      open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
          if defined $err_fh;
  
      my $errno;
      my $ok = eval {
          # The open() call here seems to not force fd 0 in some cases;
          # I ran in to trouble when using this in VCP, not sure why.
          # the dup2() seems to work.
          dup2( fileno $in_fh, 0 )
  #        open STDIN,  "<&=" . fileno $in_fh
              or croak "run3(): $! redirecting STDIN"
              if defined $in_fh;
  
  #        close $in_fh or croak "$! closing STDIN temp file"
  #            if ref $stdin;
  
          open STDOUT, ">&" . fileno $out_fh
              or croak "run3(): $! redirecting STDOUT"
              if defined $out_fh;
  
          open STDERR, ">&" . fileno $err_fh
              or croak "run3(): $! redirecting STDERR"
              if defined $err_fh;
  
          $sys_call_time = gettimeofday() if profiling;
  
          my $r = ref $cmd
                ? system { $cmd->[0] } is_win32 ? quote_native( @$cmd ) : @$cmd
                : system $cmd;
  
         $errno = $!;              # save $!, because later failures will overwrite it
          $sys_exit_time = gettimeofday() if profiling;
          if ( debugging ) {
              my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
             if ( defined $r && $r != -1 ) {
                print $err_fh "run3(): \$? is $?\n";
             } else {
                print $err_fh "run3(): \$? is $?, \$! is $errno\n";
             }
          }
  
          if (
              defined $r
              && ( $r == -1 || ( is_win32 && $r == 0xFF00 ) )
              && !$options->{return_if_system_error}
          ) {
              croak( $errno );
          }
  
          1;
      };
      my $x = $@;
  
      my @errs;
  
      if ( defined $saved_fd0 ) {
          dup2( $saved_fd0, 0 );
          POSIX::close( $saved_fd0 );
      }
  
  #    open STDIN,  "<&STDIN_SAVE"#  or push @errs, "run3(): $! restoring STDIN"
  #        if defined $in_fh;
      open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
          if defined $out_fh;
      open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
          if defined $err_fh;
  
      croak join ", ", @errs if @errs;
  
      die $x unless $ok;
  
      _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
          if defined $out_fh && $out_type && $out_type ne "FH";
      _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
          if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
      $profiler->run_exit(
         $cmd,
         $run_call_time,
         $sys_call_time,
         $sys_exit_time,
         scalar gettimeofday()
      ) if profiling;
  
      $! = $errno;              # restore $! from system()
  
      return 1;
  }
  
  1;
  
  __END__
  
  =head2 C<< run3($cmd, $stdin, $stdout, $stderr, \%options) >>
  
  All parameters after C<$cmd> are optional.
  
  The parameters C<$stdin>, C<$stdout> and C<$stderr> indicate how the child's
  corresponding filehandle (C<STDIN>, C<STDOUT> and C<STDERR>, resp.) will be
  redirected.  Because the redirects come last, this allows C<STDOUT> and
  C<STDERR> to default to the parent's by just not specifying them -- a common
  use case.
  
  C<run3> throws an exception if the wrapped C<system> call returned -1 or
  anything went wrong with C<run3>'s processing of filehandles.  Otherwise it
  returns true.  It leaves C<$?> intact for inspection of exit and wait status.
  
  Note that a true return value from C<run3> doesn't mean that the command had a
  successful exit code. Hence you should always check C<$?>.
  
  See L</%options> for an option to handle the case of C<system> returning -1
  yourself.
  
  =head3 C<$cmd>
  
  Usually C<$cmd> will be an ARRAY reference and the child is invoked via
  
    system @$cmd;
  
  But C<$cmd> may also be a string in which case the child is invoked via
  
    system $cmd;
  
  (cf. L<perlfunc/system> for the difference and the pitfalls of using
  the latter form).
  
  =head3 C<$stdin>, C<$stdout>, C<$stderr>
  
  The parameters C<$stdin>, C<$stdout> and C<$stderr> can take one of the
  following forms:
  
  =over 4
  
  =item C<undef> (or not specified at all)
  
  The child inherits the corresponding filehandle from the parent.
  
    run3 \@cmd, $stdin;                   # child writes to same STDOUT and STDERR as parent
    run3 \@cmd, undef, $stdout, $stderr;  # child reads from same STDIN as parent
  
  =item C<\undef>
  
  The child's filehandle is redirected from or to the local equivalent of
  C</dev/null> (as returned by C<< File::Spec->devnull() >>).
  
    run3 \@cmd, \undef, $stdout, $stderr; # child reads from /dev/null
  
  =item a simple scalar
  
  The parameter is taken to be the name of a file to read from
  or write to. In the latter case, the file will be opened via
  
    open FH, ">", ...
  
  i.e. it is created if it doesn't exist and truncated otherwise.
  Note that the file is opened by the parent which will L<croak|Carp/croak>
  in case of failure.
  
    run3 \@cmd, \undef, "out.txt";        # child writes to file "out.txt"
  
  =item a filehandle (either a reference to a GLOB or an C<IO::Handle>)
  
  The filehandle is inherited by the child.
  
    open my $fh, ">", "out.txt";
    print $fh "prologue\n";
    ...
    run3 \@cmd, \undef, $fh;              # child writes to $fh
    ...
    print $fh "epilogue\n";
    close $fh;
  
  =item a SCALAR reference
  
  The referenced scalar is treated as a string to be read from or
  written to. In the latter case, the previous content of the string
  is overwritten.
  
    my $out;
    run3 \@cmd, \undef, \$out;           # child writes into string
    run3 \@cmd, \<<EOF;                  # child reads from string (can use "here" notation)
    Input
    to
    child
    EOF
  
  =item an ARRAY reference
  
  For C<$stdin>, the elements of C<@$stdin> are simply spooled to the child.
  
  For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
  is read line by line (as determined by the current setting of C<$/>)
  into C<@$stdout> or C<@$stderr>, resp. The previous content of the array
  is overwritten.
  
    my @lines;
    run3 \@cmd, \undef, \@lines;         # child writes into array
  
  =item a CODE reference
  
  For C<$stdin>, C<&$stdin> will be called repeatedly (with no arguments) and
  the return values are spooled to the child. C<&$stdin> must signal the end of
  input by returning C<undef>.
  
  For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
  is read line by line (as determined by the current setting of C<$/>)
  and C<&$stdout> or C<&$stderr>, resp., is called with the contents of the line.
  Note that there's no end-of-file indication.
  
    my $i = 0;
    sub producer {
      return $i < 10 ? "line".$i++."\n" : undef;
    }
  
    run3 \@cmd, \&producer;              # child reads 10 lines
  
  Note that this form of redirecting the child's I/O doesn't imply
  any form of concurrency between parent and child - run3()'s method of
  operation is the same no matter which form of redirection you specify.
  
  =back
  
  If the same value is passed for C<$stdout> and C<$stderr>, then the child
  will write both C<STDOUT> and C<STDERR> to the same filehandle.
  In general, this means that
  
      run3 \@cmd, \undef, "foo.txt", "foo.txt";
      run3 \@cmd, \undef, \$both, \$both;
  
  will DWIM and pass a single file handle to the child for both C<STDOUT> and
  C<STDERR>, collecting all into file "foo.txt" or C<$both>.
  
  =head3 C<\%options>
  
  The last parameter, C<\%options>, must be a hash reference if present.
  
  Currently the following keys are supported:
  
  =over 4
  
  =item C<binmode_stdin>, C<binmode_stdout>, C<binmode_stderr>
  
  The value must a "layer" as described in L<perlfunc/binmode>.  If specified the
  corresponding parameter C<$stdin>, C<$stdout> or C<$stderr>, resp., operates
  with the given layer.
  
  For backward compatibility, a true value that doesn't start with ":"
  (e.g. a number) is interpreted as ":raw". If the value is false
  or not specified, the default is ":crlf" on Windows and ":raw" otherwise.
  
  Don't expect that values other than the built-in layers ":raw", ":crlf",
  and (on newer Perls) ":bytes", ":utf8", ":encoding(...)" will work.
  
  =item C<append_stdout>, C<append_stderr>
  
  If their value is true then the corresponding parameter C<$stdout> or
  C<$stderr>, resp., will append the child's output to the existing "contents" of
  the redirector. This only makes sense if the redirector is a simple scalar (the
  corresponding file is opened in append mode), a SCALAR reference (the output is
  appended to the previous contents of the string) or an ARRAY reference (the
  output is C<push>ed onto the previous contents of the array).
  
  =item C<return_if_system_error>
  
  If this is true C<run3> does B<not> throw an exception if C<system> returns -1
  (cf. L<perlfunc/system> for possible failure scenarios.), but returns true
  instead.  In this case C<$?> has the value -1 and C<$!> contains the errno of
  the failing C<system> call.
  
  =back
  
  =head1 HOW IT WORKS
  
  =over 4
  
  =item (1)
  
  For each redirector C<$stdin>, C<$stdout>, and C<$stderr>, C<run3()> furnishes
  a filehandle:
  
  =over 4
  
  =item *
  
  if the redirector already specifies a filehandle it just uses that
  
  =item *
  
  if the redirector specifies a filename, C<run3()> opens the file
  in the appropriate mode
  
  =item *
  
  in all other cases, C<run3()> opens a temporary file (using
  L<tempfile|Temp/tempfile>)
  
  =back
  
  =item (2)
  
  If C<run3()> opened a temporary file for C<$stdin> in step (1),
  it writes the data using the specified method (either
  from a string, an array or returned by a function) to the temporary file and rewinds it.
  
  =item (3)
  
  C<run3()> saves the parent's C<STDIN>, C<STDOUT> and C<STDERR> by duplicating
  them to new filehandles. It duplicates the filehandles from step (1)
  to C<STDIN>, C<STDOUT> and C<STDERR>, resp.
  
  =item (4)
  
  C<run3()> runs the child by invoking L<system|perlfunc/system> with C<$cmd> as
  specified above.
  
  =item (5)
  
  C<run3()> restores the parent's C<STDIN>, C<STDOUT> and C<STDERR> saved in step (3).
  
  =item (6)
  
  If C<run3()> opened a temporary file for C<$stdout> or C<$stderr> in step (1),
  it rewinds it and reads back its contents using the specified method (either to
  a string, an array or by calling a function).
  
  =item (7)
  
  C<run3()> closes all filehandles that it opened explicitly in step (1).
  
  =back
  
  Note that when using temporary files, C<run3()> tries to amortize the overhead
  by reusing them (i.e. it keeps them open and rewinds and truncates them
  before the next operation).
  
  =head1 LIMITATIONS
  
  Often uses intermediate files (determined by File::Temp, and thus by the
  File::Spec defaults and the TMPDIR env. variable) for speed, portability and
  simplicity.
  
  Use extreme caution when using C<run3> in a threaded environment if concurrent
  calls of C<run3> are possible. Most likely, I/O from different invocations will
  get mixed up. The reason is that in most thread implementations all threads in
  a process share the same STDIN/STDOUT/STDERR.  Known failures are Perl ithreads
  on Linux and Win32. Note that C<fork> on Win32 is emulated via Win32 threads
  and hence I/O mix up is possible between forked children here (C<run3> is "fork
  safe" on Unix, though).
  
  =head1 DEBUGGING
  
  To enable debugging use the IPCRUN3DEBUG environment variable to
  a non-zero integer value:
  
    $ IPCRUN3DEBUG=1 myapp
  
  =head1 PROFILING
  
  To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
  information to STDERR (1 to get timestamps, 2 to get a summary report at the
  END of the program, 3 to get mini reports after each run) or to a filename to
  emit raw data to a file for later analysis.
  
  =head1 COMPARISON
  
  Here's how it stacks up to existing APIs:
  
  =head2 compared to C<system()>, C<qx''>, C<open "...|">, C<open "|...">
  
  =over
  
  =item *
  
  better: redirects more than one file descriptor
  
  =item *
  
  better: returns TRUE on success, FALSE on failure
  
  =item *
  
  better: throws an error if problems occur in the parent process (or the
  pre-exec child)
  
  =item *
  
  better: allows a very perlish interface to Perl data structures and subroutines
  
  =item *
  
  better: allows 1 word invocations to avoid the shell easily:
  
   run3 ["foo"];  # does not invoke shell
  
  =item *
  
  worse: does not return the exit code, leaves it in $?
  
  =back
  
  =head2 compared to C<open2()>, C<open3()>
  
  =over
  
  =item *
  
  better: no lengthy, error prone polling/select loop needed
  
  =item *
  
  better: hides OS dependencies
  
  =item *
  
  better: allows SCALAR, ARRAY, and CODE references to source and sink I/O
  
  =item *
  
  better: I/O parameter order is like C<open3()>  (not like C<open2()>).
  
  =item *
  
  worse: does not allow interaction with the subprocess
  
  =back
  
  =head2 compared to L<IPC::Run::run()|IPC::Run/run>
  
  =over
  
  =item *
  
  better: smaller, lower overhead, simpler, more portable
  
  =item *
  
  better: no select() loop portability issues
  
  =item *
  
  better: does not fall prey to Perl closure leaks
  
  =item *
  
  worse: does not allow interaction with the subprocess (which IPC::Run::run()
  allows by redirecting subroutines)
  
  =item *
  
  worse: lacks many features of C<IPC::Run::run()> (filters, pipes, redirects,
  pty support)
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>C<barries@slaysys.com>E<gt>
  
  Ricardo SIGNES E<lt>C<rjbs@cpan.org>E<gt> performed routine maintenance since
  2010, thanks to help from the following ticket and/or patch submitters: Jody
  Belka, Roderich Schupp, David Morel, Jeff Lavallee, and anonymous others.
  
  =cut
IPC_RUN3

$fatpacked{"IPC/Run3/ProfArrayBuffer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFARRAYBUFFER';
  package IPC::Run3::ProfArrayBuffer;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  =cut
  
  use strict;
  
  =head1 METHODS
  
  =over
  
  =item C<< IPC::Run3::ProfArrayBuffer->new() >>
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
  
      my $self = bless { @_ }, $class;
  
      $self->{Events} = [];
  
      return $self;
  }
  
  =item C<< $buffer->app_call(@events) >>
  
  =item C<< $buffer->app_exit(@events) >>
  
  =item C<< $buffer->run_exit(@events) >>
  
  The three above methods push the given events onto the stack of recorded
  events.
  
  =cut
  
  for my $subname ( qw(app_call app_exit run_exit) ) {
    no strict 'refs';
    *{$subname} = sub {
        push @{shift->{Events}}, [ $subname => @_ ];
    };
  }
  
  =item get_events
  
  Returns a list of all the events.  Each event is an ARRAY reference
  like:
  
     [ "app_call", 1.1, ... ];
  
  =cut
  
  sub get_events {
      my $self = shift;
      @{$self->{Events}};
  }
  
  =back
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
  Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFARRAYBUFFER

$fatpacked{"IPC/Run3/ProfLogReader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFLOGREADER';
  package IPC::Run3::ProfLogReader;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfLogReader -  read and process a ProfLogger file
  
  =head1 SYNOPSIS
  
   use IPC::Run3::ProfLogReader;
  
   my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out"
   my $reader = IPC::Run3::ProfLogReader->new( Source => $fn );
  
   my $profiler = IPC::Run3::ProfPP;   ## For example
   my $reader   = IPC::Run3::ProfLogReader->new( ..., Handler => $p );
  
   $reader->read;
   $eaderr->read_all;
  
  =head1 DESCRIPTION
  
  Reads a log file.  Use the filename "-" to read from STDIN.
  
  =cut
  
  use strict;
  
  =head1 METHODS
  
  =head2 C<< IPC::Run3::ProfLogReader->new( ... ) >>
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
      my $self = bless { @_ }, $class;
      
      $self->{Source} = "run3.out"
          unless defined $self->{Source} && length $self->{Source};
  
      my $source = $self->{Source};
  
      if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) {
          $self->{FH} = $source;
      }
      elsif ( $source eq "-" ) {
          $self->{FH} = \*STDIN;
      }
      else {
          open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n";
          $self->{FH} = *PROFILE{IO};
      }
      return $self;
  }
  
  
  =head2 C<< $reader->set_handler( $handler ) >>
  
  =cut
  
  sub set_handler { $_[0]->{Handler} = $_[1] }
  
  =head2 C<< $reader->get_handler() >>
  
  =cut
  
  sub get_handler { $_[0]->{Handler} }
  
  =head2 C<< $reader->read() >>
  
  =cut
  
  sub read {
      my $self = shift;
  
      my $fh = $self->{FH};
      my @ln = split / /, <$fh>;
  
      return 0 unless @ln;
      return 1 unless $self->{Handler};
  
      chomp $ln[-1];
  
      ## Ignore blank and comment lines.
      return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#";
  
      if ( $ln[0] eq "\\app_call" ) {
          shift @ln;
          my @times = split /,/, pop @ln;
          $self->{Handler}->app_call(
              [
                  map {
                      s/\\\\/\\/g;
                      s/\\_/ /g;
                      $_;
                  } @ln
              ],
              @times
          );
      }
      elsif ( $ln[0] eq "\\app_exit" ) {
          shift @ln;
          $self->{Handler}->app_exit( pop @ln, @ln );
      }
      else {
          my @times = split /,/, pop @ln;
          $self->{Handler}->run_exit(
              [
                  map {
                      s/\\\\/\\/g;
                      s/\\_/ /g;
                      $_;
                  } @ln
              ],
              @times
          );
      }
  
      return 1;
  }
  
  
  =head2 C<< $reader->read_all() >>
  
  This method reads until there is nothing left to read, and then returns true.
  
  =cut
  
  sub read_all {
      my $self = shift;
  
      1 while $self->read;
  
      return 1;
  }
  
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
      Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFLOGREADER

$fatpacked{"IPC/Run3/ProfLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFLOGGER';
  package IPC::Run3::ProfLogger;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfLogger - write profiling data to a log file
  
  =head1 SYNOPSIS
  
   use IPC::Run3::ProfLogger;
  
   my $logger = IPC::Run3::ProfLogger->new;  ## write to "run3.out"
   my $logger = IPC::Run3::ProfLogger->new( Destination => $fn );
  
   $logger->app_call( \@cmd, $time );
  
   $logger->run_exit( \@cmd1, @times1 );
   $logger->run_exit( \@cmd1, @times1 );
  
   $logger->app_exit( $time );
  
  =head1 DESCRIPTION
  
  Used by IPC::Run3 to write a profiling log file.  Does not
  generate reports or maintain statistics; its meant to have minimal
  overhead.
  
  Its API is compatible with a tiny subset of the other IPC::Run profiling
  classes.
  
  =cut
  
  use strict;
  
  =head1 METHODS
  
  =head2 C<< IPC::Run3::ProfLogger->new( ... ) >>
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
      my $self = bless { @_ }, $class;
      
      $self->{Destination} = "run3.out"
          unless defined $self->{Destination} && length $self->{Destination};
  
      open PROFILE, ">$self->{Destination}"
          or die "$!: $self->{Destination}\n";
      binmode PROFILE;
      $self->{FH} = *PROFILE{IO};
  
      $self->{times} = [];
      return $self;
  }
  
  =head2 C<< $logger->run_exit( ... ) >>
  
  =cut
  
  sub run_exit {
      my $self = shift;
      my $fh = $self->{FH};
      print( $fh
          join(
              " ",
              (
                  map {
                      my $s = $_;
                      $s =~ s/\\/\\\\/g;
                      $s =~ s/ /_/g;
                      $s;
                  } @{shift()}
              ),
              join(
                  ",",
                  @{$self->{times}},
                  @_,
              ),
          ),
          "\n"
      );
  }
  
  =head2 C<< $logger->app_exit( $arg ) >>
  
  =cut
  
  sub app_exit {
      my $self = shift;
      my $fh = $self->{FH};
      print $fh "\\app_exit ", shift, "\n";
  }
  
  =head2 C<< $logger->app_call( $t, @args) >>
  
  =cut
  
  sub app_call {
      my $self = shift;
      my $fh = $self->{FH};
      my $t = shift;
      print( $fh
          join(
              " ",
              "\\app_call",
              (
                  map {
                      my $s = $_;
                      $s =~ s/\\\\/\\/g;
                      $s =~ s/ /\\_/g;
                      $s;
                  } @_
              ),
              $t,
          ),
          "\n"
      );
  }
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
  Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFLOGGER

$fatpacked{"IPC/Run3/ProfPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFPP';
  package IPC::Run3::ProfPP;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  Used by IPC::Run3 and/or run3profpp to print out profiling reports for
  human readers.  Use other classes for extracting data in other ways.
  
  The output methods are plain text, override these (see the source for
  now) to provide other formats.
  
  This class generates reports on each run3_exit() and app_exit() call.
  
  =cut
  
  require IPC::Run3::ProfReporter;
  @ISA = qw( IPC::Run3::ProfReporter );
  
  use strict;
  use POSIX qw( floor );
  
  =head1 METHODS
  
  =head2 C<< IPC::Run3::ProfPP->new() >>
  
  Returns a new profile reporting object.
  
  =cut
  
  sub _emit { shift; warn @_ }
  
  sub _t {
      sprintf "%10.6f secs", @_;
  }
  
  sub _r {
      my ( $num, $denom ) = @_;
      return () unless $denom;
      sprintf "%10.6f", $num / $denom;
  }
  
  sub _pct {
      my ( $num, $denom ) = @_;
      return () unless $denom;
      sprintf  " (%3d%%)", floor( 100 * $num / $denom + 0.5 );
  }
  
  =head2 C<< $profpp->handle_app_call() >>
  
  =cut
  
  sub handle_app_call {
      my $self = shift;
      $self->_emit("IPC::Run3 parent: ",
          join( " ", @{$self->get_app_cmd} ),
          "\n",
      );
  
      $self->{NeedNL} = 1;
  }
  
  =head2 C<< $profpp->handle_app_exit() >>
  
  =cut
  
  sub handle_app_exit {
      my $self = shift;
  
      $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1;
  
      $self->_emit( "IPC::Run3 total elapsed:             ",
          _t( $self->get_app_cumulative_time ),
          "\n");
      $self->_emit( "IPC::Run3 calls to run3():    ",
          sprintf( "%10d", $self->get_run_count ),
          "\n");
      $self->_emit( "IPC::Run3 total spent in run3():     ",
          _t( $self->get_run_cumulative_time ),
          _pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ),
          ", ",
          _r( $self->get_run_cumulative_time, $self->get_run_count ),
          " per call",
          "\n");
      my $exclusive = 
          $self->get_app_cumulative_time - $self->get_run_cumulative_time;
      $self->_emit( "IPC::Run3 total spent not in run3(): ",
          _t( $exclusive ),
          _pct( $exclusive, $self->get_app_cumulative_time ),
          "\n");
      $self->_emit( "IPC::Run3 total spent in children:   ",
          _t( $self->get_sys_cumulative_time ),
          _pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ),
          ", ",
          _r( $self->get_sys_cumulative_time, $self->get_run_count ),
          " per call",
          "\n");
      my $overhead =
          $self->get_run_cumulative_time - $self->get_sys_cumulative_time;
      $self->_emit( "IPC::Run3 total overhead:            ",
          _t( $overhead ),
          _pct(
              $overhead,
              $self->get_sys_cumulative_time
          ),
          ", ",
          _r( $overhead, $self->get_run_count ),
          " per call",
          "\n");
  }
  
  =head2 C<< $profpp->handle_run_exit() >>
  
  =cut
  
  sub handle_run_exit {
      my $self = shift;
      my $overhead = $self->get_run_time - $self->get_sys_time;
  
      $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2;
      $self->{NeedNL} = 3;
  
      $self->_emit( "IPC::Run3 child: ",
          join( " ", @{$self->get_run_cmd} ),
          "\n");
      $self->_emit( "IPC::Run3 run3()  : ", _t( $self->get_run_time ), "\n",
           "IPC::Run3 child   : ", _t( $self->get_sys_time ), "\n",
           "IPC::Run3 overhead: ", _t( $overhead ),
               _pct( $overhead, $self->get_sys_time ),
               "\n");
  }
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
      Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFPP

$fatpacked{"IPC/Run3/ProfReporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFREPORTER';
  package IPC::Run3::ProfReporter;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfReporter - base class for handling profiling data
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  See L<IPC::Run3::ProfPP|IPC::Run3::ProfPP> and for an example subclass.
  
  This class just notes and accumulates times; subclasses use methods like
  "handle_app_call", "handle_run_exit" and "handle_app_exit" to emit reports on
  it.  The default methods for these handlers are noops.
  
  If run from the command line, a reporter will be created and run on
  each logfile given as a command line parameter or on run3.out if none
  are given.
  
  This allows reports to be run like:
  
      perl -MIPC::Run3::ProfPP -e1
      perl -MIPC::Run3::ProfPP -e1 foo.out bar.out
  
  Use "-" to read from STDIN (the log file format is meant to be moderately
  greppable):
  
      grep "^cvs " run3.out perl -MIPC::Run3::ProfPP -e1 -
  
  Use --app to show only application level statistics (ie don't emit
  a report section for each command run).
  
  =cut
  
  use strict;
  
  my $loaded_by;
  
  sub import {
      $loaded_by = shift;
  }
  
  END {
      my @caller;
      for ( my $i = 0;; ++$i ) {
          my @c = caller $i;
          last unless @c;
          @caller = @c;
      }
  
      if ( $caller[0] eq "main"
          && $caller[1] eq "-e"
      ) {
          require IPC::Run3::ProfLogReader;
          require Getopt::Long;
          my ( $app, $run );
  
          Getopt::Long::GetOptions(
              "app" => \$app,
              "run" => \$run,
          );
  
          $app = 1, $run = 1 unless $app || $run;
  
          for ( @ARGV ? @ARGV : "" ) {
              my $r = IPC::Run3::ProfLogReader->new(
                  Source  => $_,
                  Handler => $loaded_by->new(
                      Source => $_,
                      app_report => $app,
                      run_report => $run,
                  ),
              );
              $r->read_all;
          }
      }
  }
  
  =head1 METHODS
  
  =over
  
  =item C<< IPC::Run3::ProfReporter->new >>
  
  Returns a new profile reporting object.
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
      my $self = bless { @_ }, $class;
      $self->{app_report} = 1, $self->{run_report} = 1
          unless $self->{app_report} || $self->{run_report};
  
      return $self;
  }
  
  =item C<< $reporter->handle_app_call( ... ) >>
  
  =item C<< $reporter->handle_app_exit( ... ) >>
  
  =item C<< $reporter->handle_run_exit( ... ) >>
  
  These methods are called by the handled events (see below).
  
  =cut
  
  sub handle_app_call {}
  sub handle_app_exit {}
  
  sub handle_run_exit {}
  
  =item C<< $reporter->app_call(\@cmd, $time) >>
  
  =item C<< $reporter->app_exit($time) >>
  
  =item C<< $reporter->run_exit(@times) >>
  
     $self->app_call( $time );
     my $time = $self->get_app_call_time;
  
  Sets the time (in floating point seconds) when the application, run3(),
  or system() was called or exited.  If no time parameter is passed, uses
  IPC::Run3's time routine.
  
  Use get_...() to retrieve these values (and _accum values, too).  This
  is a separate method to speed the execution time of the setters just a
  bit.
  
  =cut
  
  sub app_call {
      my $self = shift;
      ( $self->{app_cmd}, $self->{app_call_time} ) = @_;
      $self->handle_app_call if $self->{app_report};
  }
  
  sub app_exit {
      my $self = shift;
      $self->{app_exit_time} = shift;
      $self->handle_app_exit if $self->{app_report};
  }
  
  sub run_exit {
      my $self = shift;
      @{$self}{qw(
          run_cmd run_call_time sys_call_time sys_exit_time run_exit_time
      )} = @_;
  
      ++$self->{run_count};
      $self->{run_cumulative_time} += $self->get_run_time;
      $self->{sys_cumulative_time} += $self->get_sys_time;
      $self->handle_run_exit if $self->{run_report};
  }
  
  =item C<< $reporter->get_run_count() >>
  
  =item C<< $reporter->get_app_call_time() >>
  
  =item C<< $reporter->get_app_exit_time() >>
  
  =item C<< $reporter->get_app_cmd() >>
  
  =item C<< $reporter->get_app_time() >>
  
  =cut
  
  sub get_run_count     { shift->{run_count} }
  sub get_app_call_time { shift->{app_call_time} }
  sub get_app_exit_time { shift->{app_exit_time} }
  sub get_app_cmd       { shift->{app_cmd}       }
  sub get_app_time {
      my $self = shift;
      $self->get_app_exit_time - $self->get_app_call_time;
  }
  
  =item C<< $reporter->get_app_cumulative_time() >>
  
  =cut
  
  sub get_app_cumulative_time {
      my $self = shift;
      $self->get_app_exit_time - $self->get_app_call_time;
  }
  
  =item C<< $reporter->get_run_call_time() >>
  
  =item C<< $reporter->get_run_exit_time() >>
  
  =item C<< $reporter->get_run_time() >>
  
  =cut
  
  sub get_run_call_time { shift->{run_call_time} }
  sub get_run_exit_time { shift->{run_exit_time} }
  sub get_run_time {
      my $self = shift;
      $self->get_run_exit_time - $self->get_run_call_time;
  }
  
  =item C<< $reporter->get_run_cumulative_time() >>
  
  =cut
  
  sub get_run_cumulative_time { shift->{run_cumulative_time} }
  
  =item C<< $reporter->get_sys_call_time() >>
  
  =item C<< $reporter->get_sys_exit_time() >>
  
  =item C<< $reporter->get_sys_time() >>
  
  =cut
  
  sub get_sys_call_time { shift->{sys_call_time} }
  sub get_sys_exit_time { shift->{sys_exit_time} }
  sub get_sys_time {
      my $self = shift;
      $self->get_sys_exit_time - $self->get_sys_call_time;
  }
  
  =item C<< $reporter->get_sys_cumulative_time() >>
  
  =cut
  
  sub get_sys_cumulative_time { shift->{sys_cumulative_time} }
  
  =item C<< $reporter->get_run_cmd() >>
  
  =cut
  
  sub get_run_cmd { shift->{run_cmd} }
  
  =back
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
      Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker <barries@slaysys.com>
  
  =cut
  
  1;
IPC_RUN3_PROFREPORTER

$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
  package JSON::PP;
  
  # JSON-2.0
  
  use 5.005;
  use strict;
  
  use Exporter ();
  BEGIN { @JSON::PP::ISA = ('Exporter') }
  
  use overload ();
  use JSON::PP::Boolean;
  
  use Carp ();
  #use Devel::Peek;
  
  $JSON::PP::VERSION = '2.97001';
  
  @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
  
  # instead of hash-access, i tried index-access for speed.
  # but this method is not faster than what i expected. so it will be changed.
  
  use constant P_ASCII                => 0;
  use constant P_LATIN1               => 1;
  use constant P_UTF8                 => 2;
  use constant P_INDENT               => 3;
  use constant P_CANONICAL            => 4;
  use constant P_SPACE_BEFORE         => 5;
  use constant P_SPACE_AFTER          => 6;
  use constant P_ALLOW_NONREF         => 7;
  use constant P_SHRINK               => 8;
  use constant P_ALLOW_BLESSED        => 9;
  use constant P_CONVERT_BLESSED      => 10;
  use constant P_RELAXED              => 11;
  
  use constant P_LOOSE                => 12;
  use constant P_ALLOW_BIGNUM         => 13;
  use constant P_ALLOW_BAREKEY        => 14;
  use constant P_ALLOW_SINGLEQUOTE    => 15;
  use constant P_ESCAPE_SLASH         => 16;
  use constant P_AS_NONBLESSED        => 17;
  
  use constant P_ALLOW_UNKNOWN        => 18;
  
  use constant OLD_PERL => $] < 5.008 ? 1 : 0;
  use constant USE_B => 0;
  
  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
      );
      my @pp_bit_properties = qw(
              allow_singlequote allow_bignum loose
              allow_barekey escape_slash as_nonblessed
      );
  
      # Perl version check, Unicode handling is enabled?
      # Helper module sets @JSON::PP::_properties.
      if ( OLD_PERL ) {
          my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
          eval qq| require $helper |;
          if ($@) { Carp::croak $@; }
      }
  
      for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
          my $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,
      };
  
      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 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 $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)
           = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
                      P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
  
          ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
  
          $keysort = $canonical ? sub { $a cmp $b } : undef;
  
          if ($self->{sort_by}) {
              $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
                       : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
                       : sub { $a cmp $b };
          }
  
          encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
               if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);
  
          my $str  = $self->object_to_json($obj);
  
          $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
  
          unless ($ascii or $latin1 or $utf8) {
              utf8::upgrade($str);
          }
  
          if ($props->[ P_SHRINK ]) {
              utf8::downgrade($str, 1);
          }
  
          return $str;
      }
  
  
      sub object_to_json {
          my ($self, $obj) = @_;
          my $type = ref($obj);
  
          if($type eq 'HASH'){
              return $self->hash_to_json($obj);
          }
          elsif($type eq 'ARRAY'){
              return $self->array_to_json($obj);
          }
          elsif ($type) { # blessed object?
              if (blessed($obj)) {
  
                  return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
  
                  if ( $convert_blessed and $obj->can('TO_JSON') ) {
                      my $result = $obj->TO_JSON();
                      if ( defined $result and ref( $result ) ) {
                          if ( refaddr( $obj ) eq refaddr( $result ) ) {
                              encode_error( sprintf(
                                  "%s::TO_JSON method returned same object as was passed instead of a new one",
                                  ref $obj
                              ) );
                          }
                      }
  
                      return $self->object_to_json( $result );
                  }
  
                  return "$obj" if ( $bignum and _is_bignum($obj) );
  
                  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 "
                      . "nor convert_blessed settings are enabled", $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 ) ) {
              if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
              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) {
              if (_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/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
          $arg =~ s/\//\\\//g if ($escape_slash);
          $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
  
          if ($ascii) {
              $arg = JSON_PP_encode_ascii($arg);
          }
  
          if ($latin1) {
              $arg = JSON_PP_encode_latin1($arg);
          }
  
          if ($utf8) {
              utf8::encode($arg);
          }
  
          return '"' . $arg . '"';
      }
  
  
      sub blessed_to_json {
          my $reftype = reftype($_[1]) || '';
          if ($reftype eq 'HASH') {
              return $_[0]->hash_to_json($_[1]);
          }
          elsif ($reftype eq 'ARRAY') {
              return $_[0]->array_to_json($_[1]);
          }
          else {
              return 'null';
          }
      }
  
  
      sub encode_error {
          my $error  = shift;
          Carp::croak "$error";
      }
  
  
      sub _sort {
          defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
      }
  
  
      sub _up_indent {
          my $self  = shift;
          my $space = ' ' x $indent_length;
  
          my ($pre,$post) = ('','');
  
          $post = "\n" . $space x $indent_count;
  
          $indent_count++;
  
          $pre = "\n" . $space x $indent_count;
  
          return ($pre,$post);
      }
  
  
      sub _down_indent { $indent_count--; }
  
  
      sub PP_encode_box {
          {
              depth        => $depth,
              indent_count => $indent_count,
          };
      }
  
  } # Convert
  
  
  sub _encode_ascii {
      join('',
          map {
              $_ <= 127 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
          } unpack('U*', $_[0])
      );
  }
  
  
  sub _encode_latin1 {
      join('',
          map {
              $_ <= 255 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
          } unpack('U*', $_[0])
      );
  }
  
  
  sub _encode_surrogates { # from perlunicode
      my $uni = $_[0] - 0x10000;
      return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
  }
  
  
  sub _is_bignum {
      $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
  }
  
  
  
  #
  # JSON => Perl
  #
  
  my $max_intsize;
  
  BEGIN {
      my $checkint = 1111;
      for my $d (5..64) {
          $checkint .= 1;
          my $int   = eval qq| $checkint |;
          if ($int =~ /[eE]/) {
              $max_intsize = $d - 1;
              last;
          }
      }
  }
  
  { # PARSE 
  
      my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
          b    => "\x8",
          t    => "\x9",
          n    => "\xA",
          f    => "\xC",
          r    => "\xD",
          '\\' => '\\',
          '"'  => '"',
          '/'  => '/',
      );
  
      my $text; # json data
      my $at;   # offset
      my $ch;   # 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
  
      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)
              = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
  
          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::upgrade( $text );
              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 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 .= JSON_PP_decode_surrogates($utf16, $u) || next;
                              $utf16 = undef;
                          }
                          else {
                              if (defined $utf16) {
                                  decode_error("surrogate pair expected");
                              }
  
                              if ( ( my $hex = hex( $u ) ) > 127 ) {
                                  $is_utf8 = 1;
                                  $s .= JSON_PP_decode_unicode($u) || next;
                              }
                              else {
                                  $s .= chr $hex;
                              }
                          }
  
                      }
                      else{
                          unless ($loose) {
                              $at -= 2;
                              decode_error('illegal backslash escape sequence in string');
                          }
                          $s .= $ch;
                      }
                  }
                  else{
  
                      if ( ord $ch  > 127 ) {
                          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 =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
                              $at--;
                              decode_error('invalid character encountered while parsing JSON string');
                          }
                      }
  
                      $s .= $ch;
                  }
              }
          }
  
          decode_error("unexpected end of string while parsing JSON string");
      }
  
  
      sub white {
          while( defined $ch  ){
              if($ch 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 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 =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
              $key .= $ch;
              next_chr();
          }
          return $key;
      }
  
  
      sub word {
          my $word =  substr($text,$at-1,4);
  
          if($word eq 'true'){
              $at += 3;
              next_chr;
              return $JSON::PP::true;
          }
          elsif($word eq 'null'){
              $at += 3;
              next_chr;
              return undef;
          }
          elsif($word eq 'fals'){
              $at += 3;
              if(substr($text,$at,1) eq 'e'){
                  $at++;
                  next_chr;
                  return $JSON::PP::false;
              }
          }
  
          $at--; # for decode_error report
  
          decode_error("'null' expected")  if ($word =~ /^n/);
          decode_error("'true' expected")  if ($word =~ /^t/);
          decode_error("'false' expected") if ($word =~ /^f/);
          decode_error("malformed JSON string, neither array, object, number, string or atom");
      }
  
  
      sub number {
          my $n    = '';
          my $v;
          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;
      }
  
  
      sub is_valid_utf8 {
  
          $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
                    : $_[0] =~ /[\xC2-\xDF]/  ? 2
                    : $_[0] =~ /[\xE0-\xEF]/  ? 3
                    : $_[0] =~ /[\xF0-\xF4]/  ? 4
                    : 0
                    ;
  
          return unless $utf8_len;
  
          my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
  
          return ( $is_valid_utf8 =~ /^(?:
               [\x00-\x7F]
              |[\xC2-\xDF][\x80-\xBF]
              |[\xE0][\xA0-\xBF][\x80-\xBF]
              |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
              |[\xED][\x80-\x9F][\x80-\xBF]
              |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
              |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
          )$/x )  ? $is_valid_utf8 : '';
      }
  
  
      sub decode_error {
          my $error  = shift;
          my $no_rep = shift;
          my $str    = defined $text ? substr($text, $at) : '';
          my $mess   = '';
          my $type   = 'U*';
  
          if ( OLD_PERL ) {
              my $type   =  $] <  5.006           ? 'C*'
                          : utf8::is_utf8( $str ) ? 'U*' # 5.6
                          : 'C*'
                          ;
          }
  
          for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
              $mess .=  $c == 0x07 ? '\a'
                      : $c == 0x09 ? '\t'
                      : $c == 0x0a ? '\n'
                      : $c == 0x0d ? '\r'
                      : $c == 0x0c ? '\f'
                      : $c <  0x20 ? sprintf('\x{%x}', $c)
                      : $c == 0x5c ? '\\\\'
                      : $c <  0x80 ? chr($c)
                      : sprintf('\x{%x}', $c)
                      ;
              if ( length $mess >= 20 ) {
                  $mess .= '...';
                  last;
              }
          }
  
          unless ( length $mess ) {
              $mess = '(end of string)';
          }
  
          Carp::croak (
              $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
          );
  
      }
  
  
      sub _json_object_hook {
          my $o    = $_[0];
          my @ks = keys %{$o};
  
          if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
              my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
              if (@val == 1) {
                  return $val[0];
              }
          }
  
          my @val = $cb_object->($o) if ($cb_object);
          if (@val == 0 or @val > 1) {
              return $o;
          }
          else {
              return $val[0];
          }
      }
  
  
      sub PP_decode_box {
          {
              text    => $text,
              at      => $at,
              ch      => $ch,
              len     => $len,
              depth   => $depth,
              encoding      => $encoding,
              is_valid_utf8 => $is_valid_utf8,
          };
      }
  
  } # PARSE
  
  
  sub _decode_surrogates { # from perlunicode
      my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
      my $un  = pack('U*', $uni);
      utf8::encode( $un );
      return $un;
  }
  
  
  sub _decode_unicode {
      my $un = pack('U', hex shift);
      utf8::encode( $un );
      return $un;
  }
  
  #
  # Setup for various Perl versions (the code from JSON::PP58)
  #
  
  BEGIN {
  
      unless ( defined &utf8::is_utf8 ) {
         require Encode;
         *utf8::is_utf8 = *Encode::is_utf8;
      }
  
      if ( !OLD_PERL ) {
          *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
          *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
          *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
          *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
  
          if ($] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
              package JSON::PP;
              require subs;
              subs->import('join');
              eval q|
                  sub join {
                      return '' if (@_ < 2);
                      my $j   = shift;
                      my $str = shift;
                      for (@_) { $str .= $j . $_; }
                      return $str;
                  }
              |;
          }
      }
  
  
      sub JSON::PP::incr_parse {
          local $Carp::CarpLevel = 1;
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
      }
  
  
      sub JSON::PP::incr_skip {
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
      }
  
  
      sub JSON::PP::incr_reset {
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
      }
  
      eval q{
          sub JSON::PP::incr_text : lvalue {
              $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  
              if ( $_[0]->{_incr_parser}->{incr_pos} ) {
                  Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
              }
              $_[0]->{_incr_parser}->{incr_text};
          }
      } if ( $] >= 5.006 );
  
  } # Setup for various Perl versions (the code from JSON::PP58)
  
  
  ###############################
  # Utilities
  #
  
  BEGIN {
      eval 'require Scalar::Util';
      unless($@){
          *JSON::PP::blessed = \&Scalar::Util::blessed;
          *JSON::PP::reftype = \&Scalar::Util::reftype;
          *JSON::PP::refaddr = \&Scalar::Util::refaddr;
      }
      else{ # This code is from Scalar::Util.
          # warn $@;
          eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
          *JSON::PP::blessed = sub {
              local($@, $SIG{__DIE__}, $SIG{__WARN__});
              ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
          };
          require B;
          my %tmap = qw(
              B::NULL   SCALAR
              B::HV     HASH
              B::AV     ARRAY
              B::CV     CODE
              B::IO     IO
              B::GV     GLOB
              B::REGEXP REGEXP
          );
          *JSON::PP::reftype = sub {
              my $r = shift;
  
              return undef unless length(ref($r));
  
              my $t = ref(B::svref_2object($r));
  
              return
                  exists $tmap{$t} ? $tmap{$t}
                : length(ref($$r)) ? 'REF'
                :                    'SCALAR';
          };
          *JSON::PP::refaddr = sub {
            return undef unless length(ref($_[0]));
  
            my $addr;
            if(defined(my $pkg = blessed($_[0]))) {
              $addr .= bless $_[0], 'Scalar::Util::Fake';
              bless $_[0], $pkg;
            }
            else {
              $addr .= $_[0]
            }
  
            $addr =~ /0x(\w+)/;
            local $^W;
            #no warnings 'portable';
            hex($1);
          }
      }
  }
  
  
  # 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 { blessed $_[0] and $_[0]->isa("JSON::PP::Boolean"); }
  
  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;
  
  $JSON::PP::IncrParser::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 ) {
          if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
              utf8::upgrade( $self->{incr_text} ) ;
              utf8::decode( $self->{incr_text} ) ;
          }
          $self->{incr_text} .= $text;
      }
  
      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;
                      }
                  }
  
                  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 $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) > 0x20 ) {
                      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_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 eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) {
                      if ( !$self->{incr_nest} ) {
                          $p--; # do not eat the whitespace, let the next round do it
                          last INCR_PARSE;
                      }
                      next;
                  } 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 VERSION
  
      2.97001
  
  =head1 DESCRIPTION
  
  JSON::PP is a pure perl JSON decoder/encoder (as of RFC4627, which
  we know is obsolete but we still stick to; see below for an option
  to support part of RFC7159), 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 nor support RFC7159/ECMA-404),
  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.
  
  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>.
  
  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...
    ]
  
  =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
  
  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 with enabled C<allow_nonref>,
  resulting in an invalid JSON text:
  
     JSON::PP->new->allow_nonref->encode ("Hello, World!")
     => "Hello, World!"
  
  =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 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 (i.e. a copy of that scalar to avoid
  aliasing) is inserted into the deserialised data structure. If it returns
  an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the
  original deserialised hash will be inserted. This setting can slow down
  decoding considerably.
  
  When C<$coderef> is omitted or undefined, any existing callback will
  be removed and C<decode> will not change the deserialised hash in any
  way.
  
  Example, convert all JSON objects into the integer 5:
  
     my $js = JSON::PP->new->filter_json_object (sub { 5 });
     # returns [5]
     $js->decode ('[{}]'); # the given subroutine takes a hash reference.
     # throw an exception because allow_nonref is not enabled
     # so a lone 5 is not allowed.
     $js->decode ('{"a":1, "b":2}');
  
  =head2 filter_json_single_key_object
  
      $json = $json->filter_json_single_key_object($key [=> $coderef])
  
  Works remotely similar to C<filter_json_object>, but is only called for
  JSON objects having a single key named C<$key>.
  
  This C<$coderef> is called before the one specified via
  C<filter_json_object>, if any. It gets passed the single value in the JSON
  object. If it returns a single value, it will be inserted into the data
  structure. If it returns nothing (not even C<undef> but the empty list),
  the callback from C<filter_json_object> will be called next, as if no
  single-key callback were specified.
  
  If C<$coderef> is omitted or undefined, the corresponding callback will be
  disabled. There can only ever be one callback for a given key.
  
  As this callback gets called less often then the C<filter_json_object>
  one, decoding speed will not usually suffer as much. Therefore, single-key
  objects make excellent targets to serialise Perl objects into, especially
  as single-key JSON objects are as close to the type-tagged value concept
  as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
  support this in any way, so you need to make sure your data never looks
  like a serialised Perl hash.
  
  Typical names for the single object key are C<__class_whatever__>, or
  C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
  things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
  with real hashes.
  
  Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
  into the corresponding C<< $WIDGET{<id>} >> object:
  
     # return whatever is in $WIDGET{5}:
     JSON::PP
        ->new
        ->filter_json_single_key_object (__widget__ => sub {
              $WIDGET{ $_[0] }
           })
        ->decode ('{"__widget__": 5')
  
     # this can be used with a TO_JSON method in some "widget" class
     # for serialisation to json:
     sub WidgetBase::TO_JSON {
        my ($self) = @_;
  
        unless ($self->{id}) {
           $self->{id} = ..get..some..id..;
           $WIDGET{$self->{id}} = $self;
        }
  
        { __widget__ => $self->{id} }
     }
  
  =head2 shrink
  
      $json = $json->shrink([$enable])
      
      $enabled = $json->get_shrink
  
  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,
  try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which
  supports some of these.
  
  =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 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.
  
      $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 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.
  
      $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 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.
  
      $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 anyway.
  
  =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.
  
  =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 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 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 cannot currently force the type in other, less obscure, ways.
  
  Note that numerical precision has the same meaning as under Perl (so
  binary to decimal conversion follows the same rules as in Perl, which
  can differ to other languages). Also, your perl interpreter might expose
  extensions to the floating point numbers of your platform, such as
  infinities or NaN's - these cannot be represented in JSON, and it is an
  error to pass those in.
  
  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 for Perl objects, JSON::PP only supports a pure JSON representation (without the ability to deserialise the object automatically again).
  
  =head3 SERIALISATION
  
  What happens when C<JSON::PP> encounters a Perl object depends on the
  C<allow_blessed>, C<convert_blessed> and C<allow_bignum> settings, which are
  used in this order:
  
  =over 4
  
  =item 1. 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 2. 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 3. C<allow_blessed> is enabled.
  
  The object will be serialised as a JSON null value.
  
  =item 4. none of the above
  
  If none of the settings are enabled or the respective methods are missing,
  C<JSON::PP> throws an exception.
  
  =back
  
  =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 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>)
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2016 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
JSON_PP

$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
  package JSON::PP::Boolean;
  
  use strict;
  use overload (
      "0+"     => sub { ${$_[0]} },
      "++"     => sub { $_[0] = ${$_[0]} + 1 },
      "--"     => sub { $_[0] = ${$_[0]} - 1 },
      fallback => 1,
  );
  
  $JSON::PP::Boolean::VERSION = '2.97001';
  
  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>
  
  =cut
  
JSON_PP_BOOLEAN

$fatpacked{"Locale/Maketext/Simple.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCALE_MAKETEXT_SIMPLE';
  package Locale::Maketext::Simple;
  $Locale::Maketext::Simple::VERSION = '0.21';
  
  use strict;
  use 5.005;
  
  =head1 NAME
  
  Locale::Maketext::Simple - Simple interface to Locale::Maketext::Lexicon
  
  =head1 VERSION
  
  This document describes version 0.18 of Locale::Maketext::Simple,
  released Septermber 8, 2006.
  
  =head1 SYNOPSIS
  
  Minimal setup (looks for F<auto/Foo/*.po> and F<auto/Foo/*.mo>):
  
      package Foo;
      use Locale::Maketext::Simple;	# exports 'loc'
      loc_lang('fr');			# set language to French
      sub hello {
  	print loc("Hello, [_1]!", "World");
      }
  
  More sophisticated example:
  
      package Foo::Bar;
      use Locale::Maketext::Simple (
  	Class	    => 'Foo',	    # search in auto/Foo/
  	Style	    => 'gettext',   # %1 instead of [_1]
  	Export	    => 'maketext',  # maketext() instead of loc()
  	Subclass    => 'L10N',	    # Foo::L10N instead of Foo::I18N
  	Decode	    => 1,	    # decode entries to unicode-strings
  	Encoding    => 'locale',    # but encode lexicons in current locale
  				    # (needs Locale::Maketext::Lexicon 0.36)
      );
      sub japh {
  	print maketext("Just another %1 hacker", "Perl");
      }
  
  =head1 DESCRIPTION
  
  This module is a simple wrapper around B<Locale::Maketext::Lexicon>,
  designed to alleviate the need of creating I<Language Classes> for
  module authors.
  
  The language used is chosen from the loc_lang call. If a lookup is not
  possible, the i-default language will be used. If the lookup is not in the
  i-default language, then the key will be returned.
  
  If B<Locale::Maketext::Lexicon> is not present, it implements a
  minimal localization function by simply interpolating C<[_1]> with
  the first argument, C<[_2]> with the second, etc.  Interpolated
  function like C<[quant,_1]> are treated as C<[_1]>, with the sole
  exception of C<[tense,_1,X]>, which will append C<ing> to C<_1> when
  X is C<present>, or appending C<ed> to <_1> otherwise.
  
  =head1 OPTIONS
  
  All options are passed either via the C<use> statement, or via an
  explicit C<import>.
  
  =head2 Class
  
  By default, B<Locale::Maketext::Simple> draws its source from the
  calling package's F<auto/> directory; you can override this behaviour
  by explicitly specifying another package as C<Class>.
  
  =head2 Path
  
  If your PO and MO files are under a path elsewhere than C<auto/>,
  you may specify it using the C<Path> option.
  
  =head2 Style
  
  By default, this module uses the C<maketext> style of C<[_1]> and
  C<[quant,_1]> for interpolation.  Alternatively, you can specify the
  C<gettext> style, which uses C<%1> and C<%quant(%1)> for interpolation.
  
  This option is case-insensitive.
  
  =head2 Export
  
  By default, this module exports a single function, C<loc>, into its
  caller's namespace.  You can set it to another name, or set it to
  an empty string to disable exporting.
  
  =head2 Subclass
  
  By default, this module creates an C<::I18N> subclass under the
  caller's package (or the package specified by C<Class>), and stores
  lexicon data in its subclasses.  You can assign a name other than
  C<I18N> via this option.
  
  =head2 Decode
  
  If set to a true value, source entries will be converted into
  utf8-strings (available in Perl 5.6.1 or later).  This feature
  needs the B<Encode> or B<Encode::compat> module.
  
  =head2 Encoding
  
  Specifies an encoding to store lexicon entries, instead of
  utf8-strings.  If set to C<locale>, the encoding from the current
  locale setting is used.  Implies a true value for C<Decode>.
  
  =cut
  
  sub import {
      my ($class, %args) = @_;
  
      $args{Class}    ||= caller;
      $args{Style}    ||= 'maketext';
      $args{Export}   ||= 'loc';
      $args{Subclass} ||= 'I18N';
  
      my ($loc, $loc_lang) = $class->load_loc(%args);
      $loc ||= $class->default_loc(%args);
  
      no strict 'refs';
      *{caller(0) . "::$args{Export}"} = $loc if $args{Export};
      *{caller(0) . "::$args{Export}_lang"} = $loc_lang || sub { 1 };
  }
  
  my %Loc;
  
  sub reload_loc { %Loc = () }
  
  sub load_loc {
      my ($class, %args) = @_;
  
      my $pkg = join('::', grep { defined and length } $args{Class}, $args{Subclass});
      return $Loc{$pkg} if exists $Loc{$pkg};
  
      eval { require Locale::Maketext::Lexicon; 1 }   or return;
      $Locale::Maketext::Lexicon::VERSION > 0.20	    or return;
      eval { require File::Spec; 1 }		    or return;
  
      my $path = $args{Path} || $class->auto_path($args{Class}) or return;
      my $pattern = File::Spec->catfile($path, '*.[pm]o');
      my $decode = $args{Decode} || 0;
      my $encoding = $args{Encoding} || undef;
  
      $decode = 1 if $encoding;
  
      $pattern =~ s{\\}{/}g; # to counter win32 paths
  
      eval "
  	package $pkg;
  	use base 'Locale::Maketext';
  	Locale::Maketext::Lexicon->import({
  	    'i-default' => [ 'Auto' ],
  	    '*'	=> [ Gettext => \$pattern ],
  	    _decode => \$decode,
  	    _encoding => \$encoding,
  	});
  	*${pkg}::Lexicon = \\%${pkg}::i_default::Lexicon;
  	*tense = sub { \$_[1] . ((\$_[2] eq 'present') ? 'ing' : 'ed') }
  	    unless defined &tense;
  
  	1;
      " or die $@;
  
      my $lh = eval { $pkg->get_handle } or return;
      my $style = lc($args{Style});
      if ($style eq 'maketext') {
  	$Loc{$pkg} = sub {
  	    $lh->maketext(@_)
  	};
      }
      elsif ($style eq 'gettext') {
  	$Loc{$pkg} = sub {
  	    my $str = shift;
              $str =~ s{([\~\[\]])}{~$1}g;
              $str =~ s{
                  ([%\\]%)                        # 1 - escaped sequence
              |
                  %   (?:
                          ([A-Za-z#*]\w*)         # 2 - function call
                              \(([^\)]*)\)        # 3 - arguments
                      |
                          ([1-9]\d*|\*)           # 4 - variable
                      )
              }{
                  $1 ? $1
                     : $2 ? "\[$2,"._unescape($3)."]"
                          : "[_$4]"
              }egx;
  	    return $lh->maketext($str, @_);
  	};
      }
      else {
  	die "Unknown Style: $style";
      }
  
      return $Loc{$pkg}, sub {
  	$lh = $pkg->get_handle(@_);
      };
  }
  
  sub default_loc {
      my ($self, %args) = @_;
      my $style = lc($args{Style});
      if ($style eq 'maketext') {
  	return sub {
  	    my $str = shift;
              $str =~ s{((?<!~)(?:~~)*)\[_([1-9]\d*|\*)\]}
                       {$1%$2}g;
              $str =~ s{((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]}
                       {"$1%$2(" . _escape($3) . ')'}eg;
  	    _default_gettext($str, @_);
  	};
      }
      elsif ($style eq 'gettext') {
  	return \&_default_gettext;
      }
      else {
  	die "Unknown Style: $style";
      }
  }
  
  sub _default_gettext {
      my $str = shift;
      $str =~ s{
  	%			# leading symbol
  	(?:			# either one of
  	    \d+			#   a digit, like %1
  	    |			#     or
  	    (\w+)\(		#   a function call -- 1
  		(?:		#     either
  		    %\d+	#	an interpolation
  		    |		#     or
  		    ([^,]*)	#	some string -- 2
  		)		#     end either
  		(?:		#     maybe followed
  		    ,		#       by a comma
  		    ([^),]*)	#       and a param -- 3
  		)?		#     end maybe
  		(?:		#     maybe followed
  		    ,		#       by another comma
  		    ([^),]*)	#       and a param -- 4
  		)?		#     end maybe
  		[^)]*		#     and other ignorable params
  	    \)			#   closing function call
  	)			# closing either one of
      }{
  	my $digit = $2 || shift;
  	$digit . (
  	    $1 ? (
  		($1 eq 'tense') ? (($3 eq 'present') ? 'ing' : 'ed') :
  		($1 eq 'quant') ? ' ' . (($digit > 1) ? ($4 || "$3s") : $3) :
  		''
  	    ) : ''
  	);
      }egx;
      return $str;
  };
  
  sub _escape {
      my $text = shift;
      $text =~ s/\b_([1-9]\d*)/%$1/g;
      return $text;
  }
  
  sub _unescape {
      join(',', map {
          /\A(\s*)%([1-9]\d*|\*)(\s*)\z/ ? "$1_$2$3" : $_
      } split(/,/, $_[0]));
  }
  
  sub auto_path {
      my ($self, $calldir) = @_;
      $calldir =~ s#::#/#g;
      my $path = $INC{$calldir . '.pm'} or return;
  
      # Try absolute path name.
      if ($^O eq 'MacOS') {
  	(my $malldir = $calldir) =~ tr#/#:#;
  	$path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:#s;
      } else {
  	$path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/#;
      }
  
      return $path if -d $path;
  
      # If that failed, try relative path with normal @INC searching.
      $path = "auto/$calldir/";
      foreach my $inc (@INC) {
  	return "$inc/$path" if -d "$inc/$path";
      }
  
      return;
  }
  
  1;
  
  =head1 ACKNOWLEDGMENTS
  
  Thanks to Jos I. Boumans for suggesting this module to be written.
  
  Thanks to Chia-Liang Kao for suggesting C<Path> and C<loc_lang>.
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2003, 2004, 2005, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.  Additionally,
  when this software is distributed with B<Perl Kit, Version 5>, you may also
  redistribute it and/or modify it under the same terms as Perl itself.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =cut
LOCALE_MAKETEXT_SIMPLE

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

$fatpacked{"Menlo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO';
  package Menlo;
  our $VERSION = "1.9013";
  
  1;
  
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  Menlo - A CPAN client
  
  =head1 DESCRIPTION
  
  Menlo is a code name for I<cpanm 2.0>, developed with the goal to
  replace L<cpanm> and its backend with a more flexible, extensible and
  easier to use APIs.
  
  =head1 COMPATIBILITY
  
  Menlo is developed within L<cpanm> git repository at the C<menlo>
  branch. It keeps the developer test suite intact, which means all of
  the features implemented as of cpanm 1.7032 are supposed to work in
  Menlo with C<cpanm-menlo> command line tool and its backend,
  Menlo::CLI::Compat.
  
  Menlo::CLI::Compat started off as a copy of App::cpanminus::script,
  but will go under a big refactoring to extract all the bits out of
  it. Hopefully the end result will be just a shim and translation layer
  to interpret command line options.
  
  A new client, possibly called C<menlo>, and object oriented APIs will
  be added later in the development phase.
  
  =head1 MOTIVATION
  
  cpanm has been a popular choice of CPAN package installer for many
  developers, because it is lightweight, fast, and requires no
  configuration in most environments.
  
  Meanwhile, the way cpanm has been implemented (one God class, and all
  modules are packaged in one script with fatpacker) makes it difficult
  to extend, or modify the behaviors at a runtime, unless you decide to
  fork the code or monkeypatch its hidden backend class.
  
  cpanm also has no scriptable API or hook points, which means you have
  to work around its behavior by writing a shell wrapper, or parsing the
  output of its standard out or a build log file.
  
  Menlo will keep the best aspects of cpanm, which is dependencies free,
  configuration free, lightweight and fast to install CPAN modules. At
  the same time, it's impelmented as a standard perl module, available
  on CPAN, and you can extend its behavior by either using its modular
  interfaces, or writing plugins to hook into its behaviors.
  
  =head1 FAQ
  
  =over 4
  
  =item Dependencies free? I see many prerequisites in Menlo.
  
  Right now, Menlo is in the development phase and is released as a
  standard perl module distribution, and has a few runtime
  dependencies. Actually most of these modules were consumed by cpanm as
  well, and they aren't new.
  
  When I decide it's ready for production and to replace cpanm, I'll
  make a fatpacked version of the script, which will bundle all the
  dependencies into one file, just like cpanm does.
  
  =item Is Menlo a new name for cpanm?
  
  Right now it's just a code name, but I'm comfortable calling this a
  new package name for cpanm 2's backend.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
  
  =head1 COPYRIGHT
  
  2010- Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  This software is licensed under the same terms as Perl.
  
  =head1 SEE ALSO
  
  L<cpanm>
  
  =cut
MENLO

$fatpacked{"Menlo/Builder/Static.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_BUILDER_STATIC';
  # This is a fork of:
  #package Module::Build::Tiny;
  #$Module::Build::Tiny::VERSION = '0.039';
  package Menlo::Builder::Static;
  use strict;
  use warnings;
  
  use CPAN::Meta;
  use ExtUtils::Config 0.003;
  use ExtUtils::Helpers 0.020 qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
  use ExtUtils::Install qw/pm_to_blib install/;
  use ExtUtils::InstallPaths 0.002;
  use File::Basename qw/basename dirname/;
  use File::Find ();
  use File::Path qw/mkpath rmtree/;
  use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/;
  use Getopt::Long 2.36 qw/GetOptionsFromArray/;
  use JSON::PP 2 qw/encode_json decode_json/;
  
  sub new {
  	bless {}, shift;
  }
  
  sub get_meta {
  	my ($metafile) = grep { -e $_ } qw/META.json META.yml/ or die "No META information provided\n";
  	return CPAN::Meta->load_file($metafile);
  }
  
  sub manify {
  	my ($input_file, $output_file, $section, $opts) = @_;
  	return if -e $output_file && -M $input_file <= -M $output_file;
  	my $dirname = dirname($output_file);
  	mkpath($dirname, $opts->{verbose}) if not -d $dirname;
  	require Pod::Man;
  	Pod::Man->new(section => $section)->parse_from_file($input_file, $output_file);
  	print "Manifying $output_file\n" if $opts->{verbose} && $opts->{verbose} > 0;
  	return;
  }
  
  sub find {
  	my ($pattern, $dir) = @_;
  	my @ret;
  	File::Find::find(sub { push @ret, $File::Find::name if /$pattern/ && -f }, $dir) if -d $dir;
  	return @ret;
  }
  
  my %actions = (
  	build => sub {
  		my %opt = @_;
  		my %modules = map { $_ => catfile('blib', $_) } find(qr/\.p(?:m|od)$/, 'lib');
  		my %scripts = map { $_ => catfile('blib', $_) } find(qr//, 'script');
  		my %shared  = map { $_ => catfile(qw/blib lib auto share dist/, $opt{meta}->name, abs2rel($_, 'share')) } find(qr//, 'share');
  		pm_to_blib({ %modules, %scripts, %shared }, catdir(qw/blib lib auto/));
  		make_executable($_) for values %scripts;
  		mkpath(catdir(qw/blib arch/), $opt{verbose});
  
  		if ($opt{install_paths}->install_destination('bindoc') && $opt{install_paths}->is_default_installable('bindoc')) {
  			manify($_, catfile('blib', 'bindoc', man1_pagename($_)), $opt{config}->get('man1ext'), \%opt) for keys %scripts;
  		}
  		if ($opt{install_paths}->install_destination('libdoc') && $opt{install_paths}->is_default_installable('libdoc')) {
  			manify($_, catfile('blib', 'libdoc', man3_pagename($_)), $opt{config}->get('man3ext'), \%opt) for keys %modules;
  		}
                  1;
  	},
  	test => sub {
  		my %opt = @_;
  		die "Must run `./Build build` first\n" if not -d 'blib';
  		require TAP::Harness::Env;
  		my %test_args = (
  			(verbosity => $opt{verbose}) x!! exists $opt{verbose},
  			(jobs => $opt{jobs}) x!! exists $opt{jobs},
  			(color => 1) x !!-t STDOUT,
  			lib => [ map { rel2abs(catdir(qw/blib/, $_)) } qw/arch lib/ ],
  		);
  		my $tester = TAP::Harness::Env->create(\%test_args);
  		$tester->runtests(sort +find(qr/\.t$/, 't'))->has_errors and return;
                  1;
  	},
  	install => sub {
  		my %opt = @_;
  		die "Must run `./Build build` first\n" if not -d 'blib';
  		install($opt{install_paths}->install_map, @opt{qw/verbose dry_run uninst/});
                  1;
  	},
  	clean => sub {
  		my %opt = @_;
  		rmtree($_, $opt{verbose}) for qw/blib temp/;
  	},
  	realclean => sub {
  		my %opt = @_;
  		rmtree($_, $opt{verbose}) for qw/blib temp Build _build_params MYMETA.yml MYMETA.json/;
  	},
  );
  
  sub build {
  	my $self = shift;
  	my $action = @_ && $_[0] =~ /\A\w+\z/ ? shift @_ : 'build';
  	die "No such action '$action'\n" if not $actions{$action};
  	my %opt;
  	GetOptionsFromArray([@$_], \%opt, qw/install_base=s install_path=s% installdirs=s destdir=s prefix=s config=s% uninst:1 verbose:1 dry_run:1 pureperl-only:1 create_packlist=i jobs=i/) for ($self->{env}, $self->{configure_args}, \@_);
  	$_ = detildefy($_) for grep { defined } @opt{qw/install_base destdir prefix/}, values %{ $opt{install_path} };
  	@opt{ 'config', 'meta' } = (ExtUtils::Config->new($opt{config}), get_meta());
  	$actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name));
  }
  
  sub configure {
  	my $self = shift;   
  	my $meta = get_meta();
  	$self->{env} = defined $ENV{PERL_MB_OPT} ? [split_like_shell($ENV{PERL_MB_OPT})] : [];
          $self->{configure_args} = [@_];
  	$meta->save(@$_) for ['MYMETA.json'], [ 'MYMETA.yml' => { version => 1.4 } ];
  }
  
  1;
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Leon Timmermans, David Golden.
  
  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
MENLO_BUILDER_STATIC

$fatpacked{"Menlo/CLI/Compat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_CLI_COMPAT';
  package Menlo::CLI::Compat;
  use strict;
  use Config;
  use Cwd ();
  use Menlo;
  use Menlo::Dependency;
  use Menlo::Util qw(WIN32);
  use File::Basename ();
  use File::Find ();
  use File::Path ();
  use File::Spec ();
  use File::Copy ();
  use File::Temp ();
  use File::Which qw(which);
  use Getopt::Long ();
  use Symbol ();
  use version ();
  
  use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux');
  use constant CAN_SYMLINK => eval { symlink("", ""); 1 };
  
  our $VERSION = $Menlo::VERSION;
  
  if ($INC{"App/FatPacker/Trace.pm"}) {
      require version::vpp;
  }
  
  sub agent {
      my $self = shift;
      my $agent = "cpanminus/$VERSION";
      $agent .= " perl/$]" if $self->{report_perl_version};
      $agent;
  }
  
  sub determine_home {
      my $class = shift;
  
      my $homedir = $ENV{HOME}
        || eval { require File::HomeDir; File::HomeDir->my_home }
        || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
  
      if (WIN32) {
          require Win32; # no fatpack
          $homedir = Win32::GetShortPathName($homedir);
      }
  
      return "$homedir/.cpanm";
  }
  
  sub new {
      my $class = shift;
  
      my $self = bless {
          home => $class->determine_home,
          cmd  => 'install',
          seen => {},
          notest => undef,
          test_only => undef,
          installdeps => undef,
          force => undef,
          sudo => undef,
          make  => undef,
          verbose => undef,
          quiet => undef,
          interactive => undef,
          log => undef,
          mirrors => [],
          mirror_only => undef,
          mirror_index => undef,
          cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/",
          perl => $^X,
          argv => [],
          local_lib => undef,
          self_contained => undef,
          exclude_vendor => undef,
          prompt_timeout => 0,
          prompt => undef,
          configure_timeout => 60,
          build_timeout => 3600,
          test_timeout => 1800,
          try_lwp => 1,
          try_wget => 1,
          try_curl => 1,
          uninstall_shadows => ($] < 5.012),
          skip_installed => 1,
          skip_satisfied => 0,
          auto_cleanup => 7, # days
          pod2man => 1,
          installed_dists => 0,
          install_types => ['requires'],
          with_develop => 0,
          with_configure => 0,
          showdeps => 0,
          scandeps => 0,
          scandeps_tree => [],
          format   => 'tree',
          save_dists => undef,
          skip_configure => 0,
          verify => 0,
          report_perl_version => !$class->maybe_ci,
          build_args => {},
          features => {},
          pure_perl => 0,
          cpanfile_path => 'cpanfile',
          @_,
      }, $class;
  
      $self;
  }
  
  sub env {
      my($self, $key) = @_;
      $ENV{"PERL_CPANM_" . $key};
  }
  
  sub maybe_ci {
      my $class = shift;
      grep $ENV{$_}, qw( TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING );
  }
  
  sub install_type_handlers {
      my $self = shift;
  
      my @handlers;
      for my $type (qw( recommends suggests )) {
          push @handlers, "with-$type" => sub {
              my %uniq;
              $self->{install_types} = [ grep !$uniq{$_}++, @{$self->{install_types}}, $type ];
          };
          push @handlers, "without-$type" => sub {
              $self->{install_types} = [ grep $_ ne $type, @{$self->{install_types}} ];
          };
      }
  
      @handlers;
  }
  
  sub build_args_handlers {
      my $self = shift;
  
      my @handlers;
      for my $phase (qw( configure build test install )) {
          push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
      }
  
      @handlers;
  }
  
  sub parse_options {
      my $self = shift;
  
      local @ARGV = @{$self->{argv}};
      push @ARGV, grep length, split /\s+/, $self->env('OPT');
      push @ARGV, @_;
  
      Getopt::Long::Configure("bundling");
      Getopt::Long::GetOptions(
          'f|force'   => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
          'n|notest!' => \$self->{notest},
          'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 },
          'S|sudo!'   => \$self->{sudo},
          'v|verbose' => \$self->{verbose},
          'verify!'   => \$self->{verify},
          'q|quiet!'  => \$self->{quiet},
          'h|help'    => sub { $self->{action} = 'show_help' },
          'V|version' => sub { $self->{action} = 'show_version' },
          'perl=s'    => sub {
              $self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n", 1);
              $self->{perl} = $_[1];
          },
          'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
          'L|local-lib-contained=s' => sub {
              $self->{local_lib} = $self->maybe_abs($_[1]);
              $self->{self_contained} = 1;
              $self->{pod2man} = undef;
          },
          'self-contained!' => \$self->{self_contained},
          'exclude-vendor!' => \$self->{exclude_vendor},
          'mirror=s@' => $self->{mirrors},
          'mirror-only!' => \$self->{mirror_only},
          'mirror-index=s' => sub { $self->{mirror_index} = $self->maybe_abs($_[1]) },
          'M|from=s' => sub {
              $self->{mirrors}     = [$_[1]];
              $self->{mirror_only} = 1;
          },
          'cpanmetadb=s'    => \$self->{cpanmetadb},
          'cascade-search!' => \$self->{cascade_search},
          'prompt!'   => \$self->{prompt},
          'installdeps' => \$self->{installdeps},
          'skip-installed!' => \$self->{skip_installed},
          'skip-satisfied!' => \$self->{skip_satisfied},
          'reinstall'    => sub { $self->{skip_installed} = 0 },
          'interactive!' => \$self->{interactive},
          'i|install'    => sub { $self->{cmd} = 'install' },
          'info'         => sub { $self->{cmd} = 'info' },
          'look'         => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 },
          'U|uninstall'  => sub { $self->{cmd} = 'uninstall' },
          'self-upgrade' => sub { $self->{action} = 'self_upgrade' },
          'uninst-shadows!'  => \$self->{uninstall_shadows},
          'lwp!'    => \$self->{try_lwp},
          'wget!'   => \$self->{try_wget},
          'curl!'   => \$self->{try_curl},
          'auto-cleanup=s' => \$self->{auto_cleanup},
          'man-pages!' => \$self->{pod2man},
          'scandeps'   => \$self->{scandeps},
          'showdeps'   => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
          'format=s'   => \$self->{format},
          'save-dists=s' => sub {
              $self->{save_dists} = $self->maybe_abs($_[1]);
          },
          'skip-configure!' => \$self->{skip_configure},
          'dev!'       => \$self->{dev_release},
          'metacpan!'  => \$self->{metacpan},
          'report-perl-version!' => \$self->{report_perl_version},
          'configure-timeout=i' => \$self->{configure_timeout},
          'build-timeout=i' => \$self->{build_timeout},
          'test-timeout=i' => \$self->{test_timeout},
          'with-develop' => \$self->{with_develop},
          'without-develop' => sub { $self->{with_develop} = 0 },
          'with-configure' => \$self->{with_configure},
          'without-configure' => sub { $self->{with_configure} = 0 },
          'with-feature=s' => sub { $self->{features}{$_[1]} = 1 },
          'without-feature=s' => sub { $self->{features}{$_[1]} = 0 },
          'with-all-features' => sub { $self->{features}{__all} = 1 },
          'pp|pureperl!' => \$self->{pure_perl},
          "cpanfile=s" => \$self->{cpanfile_path},
          $self->install_type_handlers,
          $self->build_args_handlers,
      );
  
      if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm
          push @ARGV, $self->load_argv_from_fh(\*STDIN);
          $self->{load_from_stdin} = 1;
      }
  
      $self->{argv} = \@ARGV;
  }
  
  sub check_upgrade {
      my $self = shift;
      my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin};
      if ($0 eq '-') {
          # run from curl, that's fine
          return;
      } elsif ($0 !~ /^$install_base/) {
          if ($0 =~ m!perlbrew/bin!) {
              die <<DIE;
  It appears your cpanm executable was installed via `perlbrew install-cpanm`.
  cpanm --self-upgrade won't upgrade the version of cpanm you're running.
  
  Run the following command to get it upgraded.
  
    perlbrew install-cpanm
  
  DIE
          } else {
              die <<DIE;
  You are running cpanm from the path where your current perl won't install executables to.
  Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
  
    cpanm path   : $0
    Install path : $Config{installsitebin}
  
  It means you either installed cpanm globally with system perl, or use distro packages such
  as rpm or apt-get, and you have to use them again to upgrade cpanm.
  DIE
          }
      }
  }
  
  sub check_libs {
      my $self = shift;
      return if $self->{_checked}++;
      $self->bootstrap_local_lib;
  }
  
  sub setup_verify {
      my $self = shift;
  
      my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
      $self->{cpansign} = which('cpansign');
  
      unless ($has_modules && $self->{cpansign}) {
          warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
          $self->{verify} = 0;
      }
  }
  
  sub parse_module_args {
      my($self, $module) = @_;
  
      # Plack@1.2 -> Plack~"==1.2"
      # BUT don't expand @ in git URLs
      $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
  
      # Plack~1.20, DBI~"> 1.0, <= 2.0"
      if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
          return split '~', $module, 2;
      } else {
          return $module, undef;
      }
  }
  
  sub run {
      my $self = shift;
  
      my $code;
      eval {
          $code = ($self->_doit == 0);
      }; if (my $e = $@) {
          warn $e;
          $code = 1;
      }
  
      $self->{status} = $code;
  }
  
  sub status {
      $_[0]->{status};
  }
  
  sub _doit {
      my $self = shift;
  
      $self->setup_home;
      $self->init_tools;
      $self->setup_verify if $self->{verify};
  
      if (my $action = $self->{action}) {
          $self->$action() and return 1;
      }
  
      return $self->show_help(1)
          unless @{$self->{argv}} or $self->{load_from_stdin};
  
      $self->configure_mirrors;
  
      my $cwd = Cwd::cwd;
  
      my @fail;
      for my $module (@{$self->{argv}}) {
          if ($module =~ s/\.pm$//i) {
              my ($volume, $dirs, $file) = File::Spec->splitpath($module);
              $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file;
          }
          ($module, my $version) = $self->parse_module_args($module);
  
          $self->chdir($cwd);
          if ($self->{cmd} eq 'uninstall') {
              $self->uninstall_module($module)
                or push @fail, $module;
          } else {
              $self->install_module($module, 0, $version)
                  or push @fail, $module;
          }
      }
  
      if ($self->{base} && $self->{auto_cleanup}) {
          $self->cleanup_workdirs;
      }
  
      if ($self->{installed_dists}) {
          my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
          $self->diag("$self->{installed_dists} $dists installed\n", 1);
      }
  
      if ($self->{scandeps}) {
          $self->dump_scandeps();
      }
      # Workaround for older File::Temp's
      # where creating a tempdir with an implicit $PWD
      # causes tempdir non-cleanup if $PWD changes
      # as paths are stored internally without being resolved
      # absolutely.
      # https://rt.cpan.org/Public/Bug/Display.html?id=44924
      $self->chdir($cwd);
  
      return !@fail;
  }
  
  sub setup_home {
      my $self = shift;
  
      $self->{home} = $self->env('HOME') if $self->env('HOME');
  
      unless (_writable($self->{home})) {
          die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
      }
  
      $self->{base} = "$self->{home}/work/" . time . ".$$";
      File::Path::mkpath([ $self->{base} ], 0, 0777);
  
      # native path because we use shell redirect
      $self->{log} = File::Spec->catfile($self->{base}, "build.log");
      my $final_log = "$self->{home}/build.log";
  
      { open my $out, ">$self->{log}" or die "$self->{log}: $!" }
  
      if (CAN_SYMLINK) {
          my $build_link = "$self->{home}/latest-build";
          unlink $build_link;
          symlink $self->{base}, $build_link;
  
          unlink $final_log;
          symlink $self->{log}, $final_log;
      } else {
          my $log = $self->{log}; my $home = $self->{home};
          $self->{at_exit} = sub {
              my $self = shift;
              my $temp_log = "$home/build.log." . time . ".$$";
              File::Copy::copy($log, $temp_log)
                  && unlink($final_log);
              rename($temp_log, $final_log);
          }
      }
  
      $self->chat("cpanm (Menlo) $VERSION on perl $] built for $Config{archname}\n" .
                  "Work directory is $self->{base}\n");
  }
  
  sub search_mirror_index_local {
      my ($self, $local, $module, $version) = @_;
      require CPAN::Common::Index::LocalPackage;
      my $index = CPAN::Common::Index::LocalPackage->new({ source => $local });
      $self->search_common($index, { package => $module }, $version);
  }
  
  sub search_mirror_index {
      my ($self, $mirror, $module, $version) = @_;
      require Menlo::Index::Mirror;
      my $index = Menlo::Index::Mirror->new({
          mirror => $mirror,
          cache => $self->source_for($mirror),
          fetcher => sub { $self->mirror(@_) },
      });
      $self->search_common($index, { package => $module }, $version);
  }
  
  sub search_common {
      my($self, $index, $search_args, $want_version) = @_;
  
      $index->refresh_index;
  
      my $found = $index->search_packages($search_args);
      $found = $self->cpan_module_common($found) if $found;
  
      return $found unless $self->{cascade_search};
  
      if ($found) {
          if ($self->satisfy_version($found->{module}, $found->{module_version}, $want_version)) {
              return $found;
          } else {
              $self->chat("Found $found->{module} $found->{module_version} which doesn't satisfy $want_version.\n");
          }
      }
      
      return;
  }
  
  sub with_version_range {
      my($self, $version) = @_;
      defined($version) && $version =~ /(?:<|!=|==)/;
  }
  
  # version->new("1.00_00")->numify => "1.00_00" :/
  sub numify_ver {
      my($self, $ver) = @_;
      eval version->new($ver)->numify;
  }
  
  sub search_metacpan {
      my($self, $module, $version, $dev_release) = @_;
  
      require Menlo::Index::MetaCPAN;
      $self->chat("Searching $module ($version) on metacpan ...\n");
  
      my $index = Menlo::Index::MetaCPAN->new({ include_dev => $self->{dev_release} });
      my $pkg = $self->search_common($index, { package => $module, version_range => $version }, $version);
      return $pkg if $pkg;
  
      $self->diag_fail("Finding $module ($version) on metacpan failed.");
      return;
  }
  
  sub search_database {
      my($self, $module, $version) = @_;
  
      my $found;
  
      if ($self->{dev_release} or $self->{metacpan}) {
          $found = $self->search_metacpan($module, $version, $self->{dev_release})   and return $found;
          $found = $self->search_cpanmetadb($module, $version, $self->{dev_release}) and return $found;
      } else {
          $found = $self->search_cpanmetadb($module, $version) and return $found;
          $found = $self->search_metacpan($module, $version)   and return $found;
      }
  }
  
  sub search_cpanmetadb {
      my($self, $module, $version, $dev_release) = @_;
  
      require Menlo::Index::MetaDB;
      $self->chat("Searching $module ($version) on cpanmetadb ...\n");
  
      my $args = { package => $module };
      if ($self->with_version_range($version)) {
          $args->{version_range} = $version;
      }
  
      my $index = Menlo::Index::MetaDB->new({ uri => $self->{cpanmetadb} });
      my $pkg = $self->search_common($index, $args, $version);
      return $pkg if $pkg;
  
      $self->diag_fail("Finding $module on cpanmetadb failed.");
      return;
  }
  
  sub search_module {
      my($self, $module, $version) = @_;
  
      if ($self->{mirror_index}) {
          $self->mask_output( chat => "Searching $module on mirror index $self->{mirror_index} ...\n" );
          my $pkg = $self->search_mirror_index_local($self->{mirror_index}, $module, $version);
          return $pkg if $pkg;
  
          unless ($self->{cascade_search}) {
             $self->mask_output( diag_fail => "Finding $module ($version) on mirror index $self->{mirror_index} failed." );
             return;
          }
      }
  
      unless ($self->{mirror_only}) {
          my $found = $self->search_database($module, $version);
          return $found if $found;
      }
  
      MIRROR: for my $mirror (@{ $self->{mirrors} }) {
          $self->mask_output( chat => "Searching $module on mirror $mirror ...\n" );
  
          my $pkg = $self->search_mirror_index($mirror, $module, $version);
          return $pkg if $pkg;
  
          $self->mask_output( diag_fail => "Finding $module ($version) on mirror $mirror failed." );
      }
  
      return;
  }
  
  sub source_for {
      my($self, $mirror) = @_;
      $mirror =~ s/[^\w\.\-]+/%/g;
  
      my $dir = "$self->{home}/sources/$mirror";
      File::Path::mkpath([ $dir ], 0, 0777);
  
      return $dir;
  }
  
  sub load_argv_from_fh {
      my($self, $fh) = @_;
  
      my @argv;
      while(defined(my $line = <$fh>)){
          chomp $line;
          $line =~ s/#.+$//; # comment
          $line =~ s/^\s+//; # trim spaces
          $line =~ s/\s+$//; # trim spaces
  
          push @argv, split ' ', $line if $line;
      }
      return @argv;
  }
  
  sub show_version {
      my $self = shift;
  
      print "cpanm (Menlo) version $VERSION ($0)\n";
      print "perl version $] ($^X)\n\n";
  
      print "  \%Config:\n";
      for my $key (qw( archname installsitelib installsitebin installman1dir installman3dir
                       sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp )) {
          print "    $key=$Config{$key}\n" if $Config{$key};
      }
  
      print "  \%ENV:\n";
      for my $key (grep /^PERL/, sort keys %ENV) {
          print "    $key=$ENV{$key}\n";
      }
  
      print "  \@INC:\n";
      for my $inc (@INC) {
          print "    $inc\n" unless ref($inc) eq 'CODE';
      }
  
      return 1;
  }
  
  sub show_help {
      my $self = shift;
  
      if ($_[0]) {
          print <<USAGE;
  Usage: cpanm [options] Module [...]
  
  Try `cpanm --help` or `man cpanm` for more options.
  USAGE
          return;
      }
  
      print <<HELP;
  Usage: cpanm [options] Module [...]
  
  Options:
    -v,--verbose              Turns on chatty output
    -q,--quiet                Turns off the most output
    --interactive             Turns on interactive configure (required for Task:: modules)
    -f,--force                force install
    -n,--notest               Do not run unit tests
    --test-only               Run tests only, do not install
    -S,--sudo                 sudo to run install commands
    --installdeps             Only install dependencies
    --showdeps                Only display direct dependencies
    --reinstall               Reinstall the distribution even if you already have the latest version installed
    --mirror                  Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
    --mirror-only             Use the mirror's index file instead of the CPAN Meta DB
    -M,--from                 Use only this mirror base URL and its index file
    --prompt                  Prompt when configure/build/test fails
    -l,--local-lib            Specify the install base to install modules
    -L,--local-lib-contained  Specify the install base to install all non-core modules
    --self-contained          Install all non-core modules, even if they're already installed.
    --auto-cleanup            Number of days that cpanm's work directories expire in. Defaults to 7
  
  Commands:
    --self-upgrade            upgrades itself
    --info                    Displays distribution info on CPAN
    --look                    Opens the distribution with your SHELL
    -U,--uninstall            Uninstalls the modules (EXPERIMENTAL)
    -V,--version              Displays software version
  
  Examples:
  
    cpanm Test::More                                          # install Test::More
    cpanm MIYAGAWA/Plack-0.99_05.tar.gz                       # full distribution path
    cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz           # install from URL
    cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz            # install from a local file
    cpanm --interactive Task::Kensho                          # Configure interactively
    cpanm .                                                   # install from local directory
    cpanm --installdeps .                                     # install all the deps for the current directory
    cpanm -L extlib Plack                                     # install Plack and all non-core deps into extlib
    cpanm --mirror http://cpan.cpantesters.org/ DBI           # use the fast-syncing mirror
    cpanm -M https://cpan.metacpan.org App::perlbrew          # use only this secure mirror and its index
  
  You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
  
    export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
  
  Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
  
  HELP
  
      return 1;
  }
  
  sub _writable {
      my $dir = shift;
      my @dir = File::Spec->splitdir($dir);
      while (@dir) {
          $dir = File::Spec->catdir(@dir);
          if (-e $dir) {
              return -w _;
          }
          pop @dir;
      }
  
      return;
  }
  
  sub maybe_abs {
      my($self, $lib) = @_;
      if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) {
          return $lib;
      } else {
          return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib));
      }
  }
  
  sub local_lib_target {
      my($self, $root) = @_;
      # local::lib 1.008025 changed the order of PERL_LOCAL_LIB_ROOT
      (grep { $_ ne '' } split /\Q$Config{path_sep}/, $root)[0];
  }
  
  sub bootstrap_local_lib {
      my $self = shift;
  
      # If -l is specified, use that.
      if ($self->{local_lib}) {
          return $self->setup_local_lib($self->{local_lib});
      }
  
      # PERL_LOCAL_LIB_ROOT is defined. Run as local::lib mode without overwriting ENV
      if ($ENV{PERL_LOCAL_LIB_ROOT} && $ENV{PERL_MM_OPT}) {
          return $self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}), 1);
      }
  
      # root, locally-installed perl or --sudo: don't care about install_base
      return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));
  
      # local::lib is configured in the shell -- yay
      if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
          return;
      }
  
      $self->setup_local_lib;
  
      $self->diag(<<DIAG, 1);
  !
  ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
  ! To turn off this warning, you have to do one of the following:
  !   - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
  !   - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
  !   - Install local::lib by running the following commands
  !
  !         cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
  !
  DIAG
      sleep 2;
  }
  
  sub upgrade_toolchain {
      my($self, $config_deps) = @_;
  
      my %deps = map { $_->module => $_ } @$config_deps;
  
      # M::B 0.38 and EUMM 6.58 for MYMETA
      # EU::Install 1.46 for local::lib
      my $reqs = CPAN::Meta::Requirements->from_string_hash({
          'Module::Build' => '0.38',
          'ExtUtils::MakeMaker' => '6.58',
          'ExtUtils::Install' => '1.46',
      });
  
      if ($deps{"ExtUtils::MakeMaker"}) {
          $deps{"ExtUtils::MakeMaker"}->merge_with($reqs);
      } elsif ($deps{"Module::Build"}) {
          $deps{"Module::Build"}->merge_with($reqs);
          $deps{"ExtUtils::Install"} ||= Menlo::Dependency->new("ExtUtils::Install", 0, 'configure');
          $deps{"ExtUtils::Install"}->merge_with($reqs);
      }
  
      @$config_deps = values %deps;
  }
  
  sub _core_only_inc {
      my($self, $base) = @_;
      require local::lib;
      (
          local::lib->resolve_path(local::lib->install_base_arch_path($base)),
          local::lib->resolve_path(local::lib->install_base_perl_path($base)),
          (!$self->{exclude_vendor} ? grep {$_} @Config{qw(vendorarch vendorlibexp)} : ()),
          @Config{qw(archlibexp privlibexp)},
      );
  }
  
  sub _setup_local_lib_env {
      my($self, $base) = @_;
  
      $self->diag(<<WARN, 1) if $base =~ /\s/;
  WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory.
  WARN
  
      local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
      local::lib->setup_env_hash_for($base, 0);
  }
  
  sub setup_local_lib {
      my($self, $base, $no_env) = @_;
      $base = undef if $base eq '_';
  
      require local::lib;
      {
          local $0 = 'cpanm'; # so curl/wget | perl works
          $base ||= "~/perl5";
          $base = local::lib->resolve_path($base);
          if ($self->{self_contained}) {
              my @inc = $self->_core_only_inc($base);
              $self->{search_inc} = [ @inc ];
          } else {
              $self->{search_inc} = [
                  local::lib->install_base_arch_path($base),
                  local::lib->install_base_perl_path($base),
                  @INC,
              ];
          }
          $self->_setup_local_lib_env($base) unless $no_env;
          $self->{local_lib} = $base;
      }
  }
  
  sub prompt_bool {
      my($self, $mess, $def) = @_;
  
      my $val = $self->prompt($mess, $def);
      return lc $val eq 'y';
  }
  
  sub prompt {
      my($self, $mess, $def) = @_;
  
      my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
      my $dispdef = defined $def ? "[$def] " : " ";
      $def = defined $def ? $def : "";
  
      if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
          return $def;
      }
  
      local $|=1;
      local $\;
      my $ans;
      eval {
          local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
          print STDOUT "$mess $dispdef";
          alarm $self->{prompt_timeout} if $self->{prompt_timeout};
          $ans = <STDIN>;
          alarm 0;
      };
      if ( defined $ans ) {
          chomp $ans;
      } else { # user hit ctrl-D or alarm timeout
          print STDOUT "\n";
      }
  
      return (!defined $ans || $ans eq '') ? $def : $ans;
  }
  
  sub diag_ok {
      my($self, $msg) = @_;
      chomp $msg;
      $msg ||= "OK";
      if ($self->{in_progress}) {
          $self->_diag("$msg\n");
          $self->{in_progress} = 0;
      }
      $self->log("-> $msg\n");
  }
  
  sub diag_fail {
      my($self, $msg, $always) = @_;
      chomp $msg;
      if ($self->{in_progress}) {
          $self->_diag("FAIL\n");
          $self->{in_progress} = 0;
      }
  
      if ($msg) {
          $self->_diag("! $msg\n", $always, 1);
          $self->log("-> FAIL $msg\n");
      }
  }
  
  sub diag_progress {
      my($self, $msg) = @_;
      chomp $msg;
      $self->{in_progress} = 1;
      $self->_diag("$msg ... ");
      $self->log("$msg\n");
  }
  
  sub _diag {
      my($self, $msg, $always, $error) = @_;
      my $fh = $error ? *STDERR : *STDOUT;
      print {$fh} $msg if $always or $self->{verbose} or !$self->{quiet};
  }
  
  sub diag {
      my($self, $msg, $always) = @_;
      $self->_diag($msg, $always);
      $self->log($msg);
  }
  
  sub chat {
      my $self = shift;
      print STDERR @_ if $self->{verbose};
      $self->log(@_);
  }
  
  sub mask_output {
      my $self = shift;
      my $method = shift;
      $self->$method( $self->mask_uri_passwords(@_) );
  }
  
  sub log {
      my $self = shift;
      open my $out, ">>$self->{log}";
      print $out @_;
  }
  
  sub run_command {
      my($self, $cmd) = @_;
  
      # TODO move to a more appropriate runner method
      if (ref $cmd eq 'CODE') {
          if ($self->{verbose}) {
              return $cmd->();
          } else {
              require Capture::Tiny;
              open my $logfh, ">>", $self->{log};
              my $ret;
              Capture::Tiny::capture(sub { $ret = $cmd->() }, stdout => $logfh, stderr => $logfh);
              return $ret;
          }
      }
  
      if (WIN32) {
          $cmd = Menlo::Util::shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
          unless ($self->{verbose}) {
              $cmd .= " >> " . Menlo::Util::shell_quote($self->{log}) . " 2>&1";
          }
          !system $cmd;
      } else {
          my $pid = fork;
          if ($pid) {
              waitpid $pid, 0;
              return !$?;
          } else {
              $self->run_exec($cmd);
          }
      }
  }
  
  sub run_exec {
      my($self, $cmd) = @_;
  
      if (ref $cmd eq 'ARRAY') {
          unless ($self->{verbose}) {
              open my $logfh, ">>", $self->{log};
              open STDERR, '>&', $logfh;
              open STDOUT, '>&', $logfh;
              close $logfh;
          }
          exec @$cmd;
      } else {
          unless ($self->{verbose}) {
              $cmd .= " >> " . Menlo::Util::shell_quote($self->{log}) . " 2>&1";
          }
          exec $cmd;
      }
  }
  
  sub run_timeout {
      my($self, $cmd, $timeout) = @_;
  
      return $self->run_command($cmd) if ref($cmd) eq 'CODE' || WIN32 || $self->{verbose} || !$timeout;
  
      my $pid = fork;
      if ($pid) {
          eval {
              local $SIG{ALRM} = sub { die "alarm\n" };
              alarm $timeout;
              waitpid $pid, 0;
              alarm 0;
          };
          if ($@ && $@ eq "alarm\n") {
              $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");
              local $SIG{TERM} = 'IGNORE';
              kill TERM => 0;
              waitpid $pid, 0;
              return;
          }
          return !$?;
      } elsif ($pid == 0) {
          $self->run_exec($cmd);
      } else {
          $self->chat("! fork failed: falling back to system()\n");
          $self->run_command($cmd);
      }
  }
  
  sub append_args {
      my($self, $cmd, $phase) = @_;
  
      return $cmd if ref $cmd ne 'ARRAY';
      
      if (my $args = $self->{build_args}{$phase}) {
          $cmd = join ' ', Menlo::Util::shell_quote(@$cmd), $args;
      }
  
      $cmd;
  }
  
  sub configure {
      my($self, $cmd, $depth) = @_;
  
      # trick AutoInstall
      local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;
  
      # e.g. skip CPAN configuration on local::lib
      local $ENV{PERL5_CPANM_IS_RUNNING} = $$;
  
      my $use_default = !$self->{interactive};
      local $ENV{PERL_MM_USE_DEFAULT} = $use_default;
  
      local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT};
      local $ENV{PERL_MB_OPT} = $ENV{PERL_MB_OPT};
  
      # skip man page generation
      unless ($self->{pod2man}) {
          $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";
          $ENV{PERL_MB_OPT} .= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir=";
      }
  
      # Lancaster Consensus
      if ($self->{pure_perl}) {
          $ENV{PERL_MM_OPT} .= " PUREPERL_ONLY=1";
          $ENV{PERL_MB_OPT} .= " --pureperl-only";
      }
  
      local $ENV{PERL_USE_UNSAFE_INC} = 1
          unless exists $ENV{PERL_USE_UNSAFE_INC};
  
      $cmd = $self->append_args($cmd, 'configure') if $depth == 0;
  
      local $self->{verbose} = $self->{verbose} || $self->{interactive};
      $self->run_timeout($cmd, $self->{configure_timeout});
  }
  
  sub build {
      my($self, $cmd, $distname, $depth) = @_;
  
      local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
  
      local $ENV{PERL_USE_UNSAFE_INC} = 1
          unless exists $ENV{PERL_USE_UNSAFE_INC};
  
      $cmd = $self->append_args($cmd, 'build') if $depth == 0;
  
      return 1 if $self->run_timeout($cmd, $self->{build_timeout});
      while (1) {
          my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
          return                                       if $ans eq 's';
          return $self->build($cmd, $distname, $depth) if $ans eq 'r';
          $self->show_build_log                        if $ans eq 'e';
          $self->look                                  if $ans eq 'l';
      }
  }
  
  sub test {
      my($self, $cmd, $distname, $depth) = @_;
      return 1 if $self->{notest};
  
      # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
      local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
  
      # https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
      local $ENV{NONINTERACTIVE_TESTING} = !$self->{interactive};
  
      local $ENV{PERL_USE_UNSAFE_INC} = 1
          unless exists $ENV{PERL_USE_UNSAFE_INC};
  
      $cmd = $self->append_args($cmd, 'test') if $depth == 0;
  
      return 1 if $self->run_timeout($cmd, $self->{test_timeout});
      if ($self->{force}) {
          $self->diag_fail("Testing $distname failed but installing it anyway.");
          return 1;
      } else {
          $self->diag_fail;
          while (1) {
              my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?", "s");
              return                                      if $ans eq 's';
              return $self->test($cmd, $distname, $depth) if $ans eq 'r';
              return 1                                    if $ans eq 'f';
              $self->show_build_log                       if $ans eq 'e';
              $self->look                                 if $ans eq 'l';
          }
      }
  }
  
  sub install {
      my($self, $cmd, $uninst_opts, $depth) = @_;
  
      if ($depth == 0 && $self->{test_only}) {
          return 1;
      }
  
      return $self->run_command($cmd) if ref $cmd eq 'CODE';
  
      local $ENV{PERL_USE_UNSAFE_INC} = 1
          unless exists $ENV{PERL_USE_UNSAFE_INC};
  
      if ($self->{sudo}) {
          unshift @$cmd, "sudo";
      }
  
      if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
          push @$cmd, @$uninst_opts;
      }
  
      $cmd = $self->append_args($cmd, 'install') if $depth == 0;
  
      $self->run_command($cmd);
  }
  
  sub look {
      my $self = shift;
  
      my $shell = $ENV{SHELL};
      $shell  ||= $ENV{COMSPEC} if WIN32;
      if ($shell) {
          my $cwd = Cwd::cwd;
          $self->diag("Entering $cwd with $shell\n");
          system $shell;
      } else {
          $self->diag_fail("You don't seem to have a SHELL :/");
      }
  }
  
  sub show_build_log {
      my $self = shift;
  
      my @pagers = (
          $ENV{PAGER},
          (WIN32 ? () : ('less')),
          'more'
      );
      my $pager;
      while (@pagers) {
          $pager = shift @pagers;
          next unless $pager;
          $pager = which($pager);
          next unless $pager;
          last;
      }
  
      if ($pager) {
          # win32 'more' doesn't allow "more build.log", the < is required
          system("$pager < $self->{log}");
      }
      else {
          $self->diag_fail("You don't seem to have a PAGER :/");
      }
  }
  
  sub chdir {
      my $self = shift;
      Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
  }
  
  sub configure_mirrors {
      my $self = shift;
      unless (@{$self->{mirrors}}) {
          $self->{mirrors} = [ 'http://www.cpan.org' ];
      }
      for (@{$self->{mirrors}}) {
          s!^/!file:///!;
          s!/$!!;
      }
  }
  
  sub self_upgrade {
      my $self = shift;
      $self->check_upgrade;
      $self->{argv} = [ 'Menlo' ];
      return; # continue
  }
  
  sub install_module {
      my($self, $module, $depth, $version, $dep) = @_;
  
      $self->check_libs;
  
      if ($self->{seen}{$module}++) {
          # TODO: circular dependencies
          $self->chat("Already tried $module. Skipping.\n");
          return 1;
      }
  
      if ($self->{skip_satisfied}) {
          my($ok, $local) = $self->check_module($module, $version || 0);
          if ($ok) {
              $self->diag("You have $module ($local)\n", 1);
              return 1;
          }
      }
  
      my $dist = $self->resolve_name($module, $version, $dep);
      unless ($dist) {
          my $what = $module . ($version ? " ($version)" : "");
          $self->diag_fail("Couldn't find module or a distribution $what", 1);
          return;
      }
  
      if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
          $self->chat("Already tried $dist->{distvname}. Skipping.\n");
          return 1;
      }
  
      if ($self->{cmd} eq 'info') {
          print $self->format_dist($dist), "\n";
          return 1;
      }
  
      $dist->{depth} = $depth; # ugly hack
  
      if ($dist->{module}) {
          unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) {
              $self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n", 1);
              return;
          }
  
          # If a version is requested, it has to be the exact same version, otherwise, check as if
          # it is the minimum version you need.
          my $cmp = $version ? "==" : "";
          my $requirement = $dist->{module_version} ? "$cmp$dist->{module_version}" : 0;
          my($ok, $local) = $self->check_module($dist->{module}, $requirement);
          if ($self->{skip_installed} && $ok) {
              $self->diag("$dist->{module} is up to date. ($local)\n", 1);
              return 1;
          }
      }
  
      if ($dist->{dist} eq 'perl'){
          $self->diag("skipping $dist->{pathname}\n");
          return 1;
      }
  
      $self->diag("--> Working on $module\n");
  
      $dist->{dir} ||= $self->fetch_module($dist);
  
      unless ($dist->{dir}) {
          $self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1);
          return;
      }
  
      $self->chat("Entering $dist->{dir}\n");
      $self->chdir($self->{base});
      $self->chdir($dist->{dir});
  
      if ($self->{cmd} eq 'look') {
          $self->look;
          return 1;
      }
  
      return $self->build_stuff($module, $dist, $depth);
  }
  
  sub uninstall_search_path {
      my $self = shift;
  
      $self->{local_lib}
          ? (local::lib->install_base_arch_path($self->{local_lib}),
             local::lib->install_base_perl_path($self->{local_lib}))
          : @Config{qw(installsitearch installsitelib)};
  }
  
  sub uninstall_module {
      my ($self, $module) = @_;
  
      $self->check_libs;
  
      my @inc = $self->uninstall_search_path;
  
      my($metadata, $packlist) = $self->packlists_containing($module, \@inc);
      unless ($packlist) {
          $self->diag_fail(<<DIAG, 1);
  $module is not found in the following directories and can't be uninstalled.
  
  @{[ join("  \n", map "  $_", @inc) ]}
  
  DIAG
          return;
      }
  
      my @uninst_files = $self->uninstall_target($metadata, $packlist);
  
      $self->ask_permission($module, \@uninst_files) or return;
      $self->uninstall_files(@uninst_files, $packlist);
  
      $self->diag("Successfully uninstalled $module\n", 1);
  
      return 1;
  }
  
  sub packlists_containing {
      my($self, $module, $inc) = @_;
  
      require Module::Metadata;
      my $metadata = Module::Metadata->new_from_module($module, inc => $inc)
          or return;
  
      my $packlist;
      my $wanted = sub {
          return unless $_ eq '.packlist' && -f $_;
          for my $file ($self->unpack_packlist($File::Find::name)) {
              $packlist ||= $File::Find::name if $file eq $metadata->filename;
          }
      };
  
      {
          require File::pushd;
          my $pushd = File::pushd::pushd();
          my @search = grep -d $_, map File::Spec->catdir($_, 'auto'), @$inc;
          File::Find::find($wanted, @search);
      }
  
      return $metadata, $packlist;
  }
  
  sub uninstall_target {
      my($self, $metadata, $packlist) = @_;
  
      # If the module has a shadow install, or uses local::lib, then you can't just remove
      # all files in .packlist since it might have shadows in there
      if ($self->has_shadow_install($metadata) or $self->{local_lib}) {
          grep $self->should_unlink($_), $self->unpack_packlist($packlist);
      } else {
          $self->unpack_packlist($packlist);
      }
  }
  
  sub has_shadow_install {
      my($self, $metadata) = @_;
  
      # check if you have the module in site_perl *and* perl
      my @shadow = grep defined, map Module::Metadata->new_from_module($metadata->name, inc => [$_]), @INC;
      @shadow >= 2;
  }
  
  sub should_unlink {
      my($self, $file) = @_;
  
      # If local::lib is used, everything under the directory can be safely removed
      # Otherwise, bin and man files might be shared with the shadows i.e. site_perl vs perl
      # This is not 100% safe to keep the script there hoping to work with older version of .pm
      # files in the shadow, but there's nothing you can do about it.
      if ($self->{local_lib}) {
          $file =~ /^\Q$self->{local_lib}\E/;
      } else {
          !(grep $file =~ /^\Q$_\E/, @Config{qw(installbin installscript installman1dir installman3dir)});
      }
  }
  
  sub ask_permission {
      my ($self, $module, $files) = @_;
  
      $self->diag("$module contains the following files:\n\n");
      for my $file (@$files) {
          $self->diag("  $file\n");
      }
      $self->diag("\n");
  
      return 'force uninstall' if $self->{force};
      local $self->{prompt} = 1;
      return $self->prompt_bool("Are you sure you want to uninstall $module?", 'y');
  }
  
  sub unpack_packlist {
      my ($self, $packlist) = @_;
      open my $fh, '<', $packlist or die "$packlist: $!";
      map { chomp; $_ } <$fh>;
  }
  
  sub uninstall_files {
      my ($self, @files) = @_;
  
      $self->diag("\n");
  
      for my $file (@files) {
          $self->diag("Unlink: $file\n");
          unlink $file or $self->diag_fail("$!: $file");
      }
  
      $self->diag("\n");
  
      return 1;
  }
  
  sub format_dist {
      my($self, $dist) = @_;
  
      # TODO support --dist-format?
      return "$dist->{cpanid}/$dist->{filename}";
  }
  
  sub trim {
      local $_ = shift;
      tr/\n/ /d;
      s/^\s*|\s*$//g;
      $_;
  }
  
  sub fetch_module {
      my($self, $dist) = @_;
  
      $self->chdir($self->{base});
  
      for my $uri (@{$dist->{uris}}) {
          $self->mask_output( diag_progress => "Fetching $uri" );
  
          # Ugh, $dist->{filename} can contain sub directory
          my $filename = $dist->{filename} || $uri;
          my $name = File::Basename::basename($filename);
  
          my $cancelled;
          my $fetch = sub {
              my $file;
              eval {
                  local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
                  $self->mirror($uri, $name);
                  $file = $name if -e $name;
              };
              $self->diag("ERROR: " . trim("$@") . "\n", 1) if $@ && $@ ne "SIGINT\n";
              return $file;
          };
  
          my($try, $file);
          while ($try++ < 3) {
              $file = $fetch->();
              last if $cancelled or $file;
              $self->mask_output( diag_fail => "Download $uri failed. Retrying ... ");
          }
  
          if ($cancelled) {
              $self->diag_fail("Download cancelled.");
              return;
          }
  
          unless ($file) {
              $self->mask_output( diag_fail => "Failed to download $uri");
              next;
          }
  
          $self->diag_ok;
          $dist->{local_path} = File::Spec->rel2abs($name);
  
          my $dir = $self->unpack($file, $uri, $dist);
          next unless $dir; # unpack failed
  
          if (my $save = $self->{save_dists}) {
              # Only distros retrieved from CPAN have a pathname set
              my $path = $dist->{pathname} ? "$save/authors/id/$dist->{pathname}"
                                           : "$save/vendor/$file";
              $self->chat("Copying $name to $path\n");
              File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777);
              File::Copy::copy($file, $path) or warn $!;
          }
  
          return $dist, $dir;
      }
  }
  
  sub unpack {
      my($self, $file, $uri, $dist) = @_;
  
      if ($self->{verify}) {
          $self->verify_archive($file, $uri, $dist) or return;
      }
  
      $self->chat("Unpacking $file\n");
      my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file);
      unless ($dir) {
          $self->diag_fail("Failed to unpack $file: no directory");
      }
      return $dir;
  }
  
  sub verify_checksums_signature {
      my($self, $chk_file) = @_;
  
      require Module::Signature; # no fatpack
  
      $self->chat("Verifying the signature of CHECKSUMS\n");
  
      my $rv = eval {
          local $SIG{__WARN__} = sub {}; # suppress warnings
          my $v = Module::Signature::_verify($chk_file);
          $v == Module::Signature::SIGNATURE_OK();
      };
      if ($rv) {
          $self->chat("Verified OK!\n");
      } else {
          $self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");
          return;
      }
  
      return 1;
  }
  
  sub verify_archive {
      my($self, $file, $uri, $dist) = @_;
  
      unless ($dist->{cpanid}) {
          $self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
          return 1;
      }
  
      (my $mirror = $uri) =~ s!/authors/id.*$!!;
  
      (my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!;
      my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS";
      $self->mask_output( diag_progress => "Fetching $chksum_uri" );
      $self->mirror($chksum_uri, $chk_file);
  
      unless (-e $chk_file) {
          $self->diag_fail("Fetching $chksum_uri failed.\n");
          return;
      }
  
      $self->diag_ok;
      $self->verify_checksums_signature($chk_file) or return;
      $self->verify_checksum($file, $chk_file);
  }
  
  sub verify_checksum {
      my($self, $file, $chk_file) = @_;
  
      $self->chat("Verifying the SHA1 for $file\n");
  
      open my $fh, "<$chk_file" or die "$chk_file: $!";
      my $data = join '', <$fh>;
      $data =~ s/\015?\012/\n/g;
  
      require Safe; # no fatpack
      my $chksum = Safe->new->reval($data);
  
      if (!ref $chksum or ref $chksum ne 'HASH') {
          $self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");
          return;
      }
  
      if (my $sha = $chksum->{$file}{sha256}) {
          my $hex = $self->sha_for(256, $file);
          if ($hex eq $sha) {
              $self->chat("Checksum for $file: Verified!\n");
          } else {
              $self->diag_fail("Checksum mismatch for $file\n");
              return;
          }
      } else {
          $self->chat("Checksum for $file not found in CHECKSUMS.\n");
          return;
      }
  }
  
  sub sha_for {
      my($self, $alg, $file) = @_;
  
      require Digest::SHA; # no fatpack
  
      open my $fh, "<", $file or die "$file: $!";
      my $dg = Digest::SHA->new($alg);
      my($data);
      while (read($fh, $data, 4096)) {
          $dg->add($data);
      }
  
      return $dg->hexdigest;
  }
  
  sub verify_signature {
      my($self, $dist) = @_;
  
      $self->diag_progress("Verifying the SIGNATURE file");
      my $out = `$self->{cpansign} -v --skip 2>&1`;
      $self->log($out);
  
      if ($out =~ /Signature verified OK/) {
          $self->diag_ok("Verified OK");
          return 1;
      } else {
          $self->diag_fail("SIGNATURE verification for $dist->{filename} failed\n");
          return;
      }
  }
  
  sub resolve_name {
      my($self, $module, $version, $dep) = @_;
  
      if ($dep && $dep->url) {
          if ($dep->url =~ m!authors/id/(.*)!) {
              return $self->cpan_dist($1, $dep->url);
          } else {
              return { uris => [ $dep->url ] };
          }
      }
  
      if ($dep && $dep->dist) {
          return $self->cpan_dist($dep->dist, undef, $dep->mirror);
      }
  
      # Git
      if ($module =~ /(?:^git:|\.git(?:@.+)?$)/) {
          return $self->git_uri($module);
      }
  
      # URL
      if ($module =~ /^(ftp|https?|file):/) {
          if ($module =~ m!authors/id/(.*)!) {
              return $self->cpan_dist($1, $module);
          } else {
              return { uris => [ $module ] };
          }
      }
  
      # Directory
      if ($module =~ m!^[\./]! && -d $module) {
          return {
              source => 'local',
              dir => Cwd::abs_path($module),
          };
      }
  
      # File
      if (-f $module) {
          return {
              source => 'local',
              uris => [ "file://" . Cwd::abs_path($module) ],
          };
      }
  
      # cpan URI
      if ($module =~ s!^cpan:///distfile/!!) {
          return $self->cpan_dist($module);
      }
  
      # PAUSEID/foo
      # P/PA/PAUSEID/foo
      if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!) {
          return $self->cpan_dist($1);
      }
  
      # Module name
      return $self->search_module($module, $version);
  }
  
  sub cpan_module_common {
      my($self, $match) = @_;
  
      (my $distfile = $match->{uri}) =~ s!^cpan:///distfile/!!;
  
      my $mirrors = $self->{mirrors};
      if ($match->{download_uri}) {
          (my $mirror = $match->{download_uri}) =~ s!/authors/id/.*$!!;
          $mirrors = [$mirror];
      }
  
      local $self->{mirrors} = $mirrors;
      return $self->cpan_module($match->{package}, $distfile, $match->{version});
  }
  
  sub cpan_module {
      my($self, $module, $dist_file, $version) = @_;
  
      my $dist = $self->cpan_dist($dist_file);
      $dist->{module} = $module;
      $dist->{module_version} = $version if $version && $version ne 'undef';
  
      return $dist;
  }
  
  sub cpan_dist {
      my($self, $dist, $url, $mirror) = @_;
  
      # strip trailing slash
      $mirror =~ s!/$!! if $mirror;
  
      $dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;
  
      require CPAN::DistnameInfo;
      my $d = CPAN::DistnameInfo->new($dist);
  
      if ($url) {
          $url = [ $url ] unless ref $url eq 'ARRAY';
      } else {
          my $id = $d->cpanid;
          my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename;
  
          my @mirrors = $mirror ? ($mirror) : @{$self->{mirrors}};
          my @urls    = map "$_/authors/id/$fn", @mirrors;
  
          $url = \@urls,
      }
  
      return {
          $d->properties,
          source  => 'cpan',
          uris    => $url,
      };
  }
  
  sub git_uri {
      my ($self, $uri) = @_;
  
      # similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support
      # git URL has to end with .git when you need to use pin @ commit/tag/branch
  
      ($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2;
  
      my $dir = File::Temp::tempdir(CLEANUP => 1);
  
      $self->mask_output( diag_progress => "Cloning $uri" );
      $self->run_command([ 'git', 'clone', $uri, $dir ]);
  
      unless (-e "$dir/.git") {
          $self->diag_fail("Failed cloning git repository $uri", 1);
          return;
      }
  
      if ($commitish) {
          require File::pushd;
          my $dir = File::pushd::pushd($dir);
  
          unless ($self->run_command([ 'git', 'checkout', $commitish ])) {
              $self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");
              return;
          }
      }
  
      $self->diag_ok;
  
      return {
          source => 'local',
          dir    => $dir,
      };
  }
  
  sub core_version_for {
      my($self, $module) = @_;
  
      require Module::CoreList; # no fatpack
      unless (exists $Module::CoreList::version{$]+0}) {
          die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " .
                      "You're strongly recommended to upgrade Module::CoreList from CPAN.\n",
                      $Module::CoreList::VERSION, $INC{"Module/CoreList.pm"});
      }
  
      unless (exists $Module::CoreList::version{$]+0}{$module}) {
          return -1;
      }
  
      return $Module::CoreList::version{$]+0}{$module};
  }
  
  sub search_inc {
      my $self = shift;
      $self->{search_inc} ||= do {
          # strip lib/ and fatlib/ from search path when booted from dev
          if (defined $::Bin) {
              [grep !/^\Q$::Bin\E\/..\/(?:fat)?lib$/, @INC]
          } else {
              [@INC]
          }
      };
  }
  
  sub check_module {
      my($self, $mod, $want_ver) = @_;
  
      require Module::Metadata;
      my $meta = Module::Metadata->new_from_module($mod, inc => $self->search_inc)
          or return 0, undef;
  
      my $version = $meta->version;
  
      # When -L is in use, the version loaded from 'perl' library path
      # might be newer than (or actually wasn't core at) the version
      # that is shipped with the current perl
      if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) {
          $version = $self->core_version_for($mod);
          return 0, undef if $version && $version == -1;
      }
  
      $self->{local_versions}{$mod} = $version;
  
      if ($self->is_deprecated($meta)){
          return 0, $version;
      } elsif ($self->satisfy_version($mod, $version, $want_ver)) {
          return 1, ($version || 'undef');
      } else {
          return 0, $version;
      }
  }
  
  sub satisfy_version {
      my($self, $mod, $version, $want_ver) = @_;
  
      $want_ver = '0' unless defined($want_ver) && length($want_ver);
  
      require CPAN::Meta::Requirements;
      my $requirements = CPAN::Meta::Requirements->new;
      $requirements->add_string_requirement($mod, $want_ver);
      $requirements->accepts_module($mod, $version);
  }
  
  sub unsatisfy_how {
      my($self, $ver, $want_ver) = @_;
  
      if ($want_ver =~ /^[v0-9\.\_]+$/) {
          return "$ver < $want_ver";
      } else {
          return "$ver doesn't satisfy $want_ver";
      }
  }
  
  sub is_deprecated {
      my($self, $meta) = @_;
  
      my $deprecated = eval {
          require Module::CoreList; # no fatpack
          Module::CoreList::is_deprecated($meta->{module});
      };
  
      return $deprecated && $self->loaded_from_perl_lib($meta);
  }
  
  sub loaded_from_perl_lib {
      my($self, $meta) = @_;
  
      require Config;
      my @dirs = qw(archlibexp privlibexp);
      if ($self->{self_contained} && ! $self->{exclude_vendor} && $Config{vendorarch}) {
          unshift @dirs, qw(vendorarch vendorlibexp);
      }
      for my $dir (@dirs) {
          my $confdir = $Config{$dir};
          if ($confdir eq substr($meta->filename, 0, length($confdir))) {
              return 1;
          }
      }
  
      return;
  }
  
  sub should_install {
      my($self, $mod, $ver) = @_;
  
      $self->chat("Checking if you have $mod $ver ... ");
      my($ok, $local) = $self->check_module($mod, $ver);
  
      if ($ok)       { $self->chat("Yes ($local)\n") }
      elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") }
      else           { $self->chat("No\n") }
  
      return $mod unless $ok;
      return;
  }
  
  sub check_perl_version {
      my($self, $version) = @_;
      require CPAN::Meta::Requirements;
      my $req = CPAN::Meta::Requirements->from_string_hash({ perl => $version });
      $req->accepts_module(perl => $]);
  }
  
  sub install_deps {
      my($self, $dir, $depth, @deps) = @_;
  
      my(@install, %seen, @fail);
      for my $dep (@deps) {
          next if $seen{$dep->module};
          if ($dep->module eq 'perl') {
              if ($dep->is_requirement && !$self->check_perl_version($dep->version)) {
                  $self->diag("Needs perl @{[$dep->version]}, you have $]\n");
                  push @fail, 'perl';
              }
          } elsif ($self->should_install($dep->module, $dep->version)) {
              push @install, $dep;
              $seen{$dep->module} = 1;
          }
      }
  
      if (@install) {
          $self->diag("==> Found dependencies: " . join(", ",  map $_->module, @install) . "\n");
      }
  
      for my $dep (@install) {
          $self->install_module($dep->module, $depth + 1, $dep->version, $dep);
      }
  
      $self->chdir($self->{base});
      $self->chdir($dir) if $dir;
  
      if ($self->{scandeps}) {
          return 1; # Don't check if dependencies are installed, since with --scandeps they aren't
      }
      my @not_ok = $self->unsatisfied_deps(@deps);
      if (@not_ok) {
          return 0, \@not_ok;
      } else {
          return 1;
      }
  }
  
  sub unsatisfied_deps {
      my($self, @deps) = @_;
  
      require CPAN::Meta::Check;
      require CPAN::Meta::Requirements;
  
      my $reqs = CPAN::Meta::Requirements->new;
      for my $dep (grep $_->is_requirement, @deps) {
          $reqs->add_string_requirement($dep->module => $dep->requires_version || '0');
      }
  
      my $ret = CPAN::Meta::Check::check_requirements($reqs, 'requires', $self->{search_inc});
      grep defined, values %$ret;
  }
  
  sub install_deps_bailout {
      my($self, $target, $dir, $depth, @deps) = @_;
  
      my($ok, $fail) = $self->install_deps($dir, $depth, @deps);
      if (!$ok) {
          $self->diag_fail("Installing the dependencies failed: " . join(", ", @$fail), 1);
          unless ($self->prompt_bool("Do you want to continue building $target anyway?", "n")) {
              $self->diag_fail("Bailing out the installation for $target.", 1);
              return;
          }
      }
  
      return 1;
  }
  
  sub build_stuff {
      my($self, $stuff, $dist, $depth) = @_;
  
      if ($self->{verify} && -e 'SIGNATURE') {
          $self->verify_signature($dist) or return;
      }
  
      require CPAN::Meta;
  
      my($meta_file) = grep -f, qw(META.json META.yml);
      if ($meta_file) {
          $self->chat("Checking configure dependencies from $meta_file\n");
          $dist->{cpanmeta} = eval { CPAN::Meta->load_file($meta_file) };
      } elsif ($dist->{dist} && $dist->{version}) {
          $self->chat("META.yml/json not found. Creating skeleton for it.\n");
          $dist->{cpanmeta} = CPAN::Meta->new({ name => $dist->{dist}, version => $dist->{version} });
      }
  
      $dist->{meta} = $dist->{cpanmeta} ? $dist->{cpanmeta}->as_struct : {};
  
      my @config_deps;
  
      if ($dist->{cpanmeta}) {
          push @config_deps, Menlo::Dependency->from_prereqs(
              $dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
          );
      }
  
      if (-e 'Build.PL' && !@config_deps) {
          push @config_deps, Menlo::Dependency->from_versions(
              { 'Module::Build' => '0.38' }, 'configure',
          );
      }
  
      $self->merge_with_cpanfile($dist, \@config_deps);
  
      $self->upgrade_toolchain(\@config_deps);
  
      my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
  
      unless ($self->skip_configure($dist, $depth)) {
          $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
            or return;
      }
  
      $self->diag_progress("Configuring $target");
  
      my $configure_state = $self->configure_this($dist, $depth);
      $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
  
      if ($dist->{cpanmeta} && $dist->{source} eq 'cpan') {
          $dist->{provides} = $dist->{cpanmeta}{provides} || $self->extract_packages($dist->{cpanmeta}, ".");
      }
  
      # install direct 'test' dependencies for --installdeps, even with --notest
      # TODO: remove build dependencies for static install
      my $deps_only = $self->deps_only($depth);
      $dist->{want_phases} = $self->{notest} && !$self->deps_only($depth)
                           ? [qw( build runtime )] : [qw( build test runtime )];
  
      push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0;
      push @{$dist->{want_phases}}, 'configure' if $self->{with_configure} && $depth == 0;
  
      my @deps = $self->find_prereqs($dist);
      my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
      $module_name =~ s/-/::/g;
  
      if ($self->{showdeps}) {
          for my $dep (@config_deps, @deps) {
              print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n";
          }
          return 1;
      }
  
      my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
  
      my $walkup;
      if ($self->{scandeps}) {
          $walkup = $self->scandeps_append_child($dist);
      }
  
      $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
          or return;
  
      if ($self->{scandeps}) {
          unless ($configure_state->{configured_ok}) {
              my $diag = <<DIAG;
  ! Configuring $distname failed. See $self->{log} for details.
  ! You might have to install the following modules first to get --scandeps working correctly.
  DIAG
              if (@config_deps) {
                  my @tree = @{$self->{scandeps_tree}};
                  $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree;
              }
              $self->diag("!\n$diag!\n", 1);
          }
          $walkup->();
          return 1;
      }
  
      if ($self->{installdeps} && $depth == 0) {
          if ($configure_state->{configured_ok}) {
              $self->diag("<== Installed dependencies for $stuff. Finishing.\n");
              return 1;
          } else {
              $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1);
              return;
          }
      }
  
      my $installed;
      if ($configure_state->{static_install}) {
          $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
          $self->build(sub { $configure_state->{static_install}->build }, $distname, $depth) &&
          $self->test(sub { $configure_state->{static_install}->build("test") }, $distname, $depth) &&
          $self->install(sub { $configure_state->{static_install}->build("install") }, [], $depth) &&
          $installed++;
      } elsif ($configure_state->{use_module_build} && -e 'Build' && -f _) {
          $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
          $self->build([ $self->{perl}, "./Build" ], $distname, $depth) &&
          $self->test([ $self->{perl}, "./Build", "test" ], $distname, $depth) &&
          $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $depth) &&
          $installed++;
      } elsif ($self->{make} && -e 'Makefile') {
          $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
          $self->build([ $self->{make} ], $distname, $depth) &&
          $self->test([ $self->{make}, "test" ], $distname, $depth) &&
          $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $depth) &&
          $installed++;
      } else {
          my $why;
          my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok};
          if ($configure_failed) { $why = "Configure failed for $distname." }
          elsif ($self->{make})  { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" }
          else                   { $why = "Can't configure the distribution. You probably need to have 'make'." }
  
          $self->diag_fail("$why See $self->{log} for details.", 1);
          return;
      }
  
      if ($installed && $self->{test_only}) {
          $self->diag_ok;
          $self->diag("Successfully tested $distname\n", 1);
      } elsif ($installed) {
          my $local   = $self->{local_versions}{$dist->{module} || ''};
          my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version};
          my $reinstall = $local && ($local eq $version);
          my $action  = $local && !$reinstall
                      ? $self->numify_ver($version) < $self->numify_ver($local)
                          ? "downgraded"
                          : "upgraded"
                      : undef;
  
          my $how = $reinstall ? "reinstalled $distname"
                  : $local     ? "installed $distname ($action from $local)"
                               : "installed $distname" ;
          my $msg = "Successfully $how";
          $self->diag_ok;
          $self->diag("$msg\n", 1);
          $self->{installed_dists}++;
          $self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps);
          return 1;
      } else {
          my $what = $self->{test_only} ? "Testing" : "Installing";
          $self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.", 1);
          return;
      }
  }
  
  sub opts_in_static_install {
      my($self, $meta) = @_;
  
      # --sudo requires running a separate shell to prevent persistent configuration
      # uninstall-shadows (default on < 5.12) is not supported in BuildPL spec, yet.
  
      return $meta->{x_static_install} &&
             !($self->{sudo} or $self->{uninstall_shadows});
  }
  
  
  sub skip_configure {
      my($self, $dist, $depth) = @_;
  
      return 1 if $self->{skip_configure};
      return 1 if $self->opts_in_static_install($dist->{meta});
      return 1 if $self->no_dynamic_config($dist->{meta}) && $self->deps_only($depth);
  
      return;
  }
  
  sub no_dynamic_config {
      my($self, $meta) = @_;
      exists $meta->{dynamic_config} && $meta->{dynamic_config} == 0;
  }
  
  sub deps_only {
      my($self, $depth) = @_;
      ($self->{installdeps} && $depth == 0)
        or $self->{showdeps}
        or $self->{scandeps};
  }
  
  sub perl_requirements {
      my($self, @requires) = @_;
  
      my @perl;
      for my $requires (grep defined, @requires) {
          if (exists $requires->{perl}) {
              push @perl, Menlo::Dependency->new(perl => $requires->{perl});
          }
      }
  
      return @perl;
  }
  
  sub configure_this {
      my($self, $dist, $depth) = @_;
  
      my $deps_only = $self->deps_only($depth);
      if (-e $self->{cpanfile_path} && $deps_only) {
          require Module::CPANfile;
          $dist->{cpanfile} = eval { Module::CPANfile->load($self->{cpanfile_path}) };
          $self->diag_fail($@, 1) if $@;
  
          $self->{cpanfile_global} ||= $dist->{cpanfile};
  
          return {
              configured       => 1,
              configured_ok    => !!$dist->{cpanfile},
              use_module_build => 0,
          };
      }
  
      if ($self->{skip_configure}) {
          my $eumm = -e 'Makefile';
          my $mb   = -e 'Build' && -f _;
          return {
              configured => 1,
              configured_ok => $eumm || $mb,
              use_module_build => $mb,
          };
      }
  
      if ($deps_only && $self->no_dynamic_config($dist->{meta})) {
          return {
              configured => 1,
              configured_ok => exists $dist->{meta}{prereqs},
              use_module_build => 0,
          };
      }
  
      my $state = {};
  
      my $try_static = sub {
          if ($self->opts_in_static_install($dist->{meta})) {
              $self->chat("Distribution opts in x_static_install: $dist->{meta}{x_static_install}\n");
              $self->static_install_configure($state, $dist, $depth);
          }
      };
  
      my $try_eumm = sub {
          if (-e 'Makefile.PL') {
              $self->chat("Running Makefile.PL\n");
  
              # NOTE: according to Devel::CheckLib, most XS modules exit
              # with 0 even if header files are missing, to avoid receiving
              # tons of FAIL reports in such cases. So exit code can't be
              # trusted if it went well.
              if ($self->configure([ $self->{perl}, "Makefile.PL" ], $depth)) {
                  $state->{configured_ok} = -e 'Makefile';
              }
              $state->{configured}++;
          }
      };
  
      my $try_mb = sub {
          if (-e 'Build.PL') {
              $self->chat("Running Build.PL\n");
              if ($self->configure([ $self->{perl}, "Build.PL" ], $depth)) {
                  $state->{configured_ok} = -e 'Build' && -f _;
              }
              $state->{use_module_build}++;
              $state->{configured}++;
          }
      };
  
      for my $try ($try_static, $try_mb, $try_eumm) {
          $try->();
          last if $state->{configured_ok};
      }
  
      unless ($state->{configured_ok}) {
          while (1) {
              my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
              last                                        if $ans eq 's';
              return $self->configure_this($dist, $depth) if $ans eq 'r';
              $self->show_build_log                       if $ans eq 'e';
              $self->look                                 if $ans eq 'l';
          }
      }
  
      return $state;
  }
  
  sub static_install_configure {
      my($self, $state, $dist, $depth) = @_;
  
      my $args = $depth == 0 ? $self->{build_args}{configure} : [];
  
      require Menlo::Builder::Static;
      my $builder = Menlo::Builder::Static->new;
      $self->configure(sub { $builder->configure($args || []) }, $depth);
  
      $state->{configured_ok} = 1;
      $state->{static_install} = $builder;
      $state->{configured}++;
  }
  
  sub find_module_name {
      my($self, $state) = @_;
  
      return unless $state->{configured_ok};
  
      if ($state->{use_module_build} &&
          -e "_build/build_params") {
          my $params = do { open my $in, "_build/build_params"; eval(join "", <$in>) };
          return eval { $params->[2]{module_name} } || undef;
      } elsif (-e "Makefile") {
          open my $mf, "Makefile";
          while (<$mf>) {
              if (/^\#\s+NAME\s+=>\s+(.*)/) {
                  return eval($1);
              }
          }
      }
  
      return;
  }
  
  sub list_files {
      my $self = shift;
  
      if (-e 'MANIFEST') {
          require ExtUtils::Manifest;
          my $manifest = eval { ExtUtils::Manifest::manifind() } || {};
          return sort { lc $a cmp lc $b } keys %$manifest;
      } else {
          require File::Find;
          my @files;
          my $finder = sub {
              my $name = $File::Find::name;
              $name =~ s!\.[/\\]!!;
              push @files, $name;
          };
          File::Find::find($finder, ".");
          return sort { lc $a cmp lc $b } @files;
      }
  }
  
  sub extract_packages {
      my($self, $meta, $dir) = @_;
  
      my $try = sub {
          my $file = shift;
          return 0 if $file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;
          return 1 unless $meta->{no_index};
          return 0 if grep { $file =~ m!^$_/! } @{$meta->{no_index}{directory} || []};
          return 0 if grep { $file eq $_ } @{$meta->{no_index}{file} || []};
          return 1;
      };
  
      require Parse::PMFile;
  
      my @files = grep { /\.pm(?:\.PL)?$/ && $try->($_) } $self->list_files;
  
      my $provides = { };
  
      for my $file (@files) {
          my $parser = Parse::PMFile->new($meta, { UNSAFE => 1, ALLOW_DEV_VERSION => 1 });
          my $packages = $parser->parse($file);
  
          while (my($package, $meta) = each %$packages) {
              $provides->{$package} ||= {
                  file => $meta->{infile},
                  ($meta->{version} eq 'undef') ? () : (version => $meta->{version}),
              };
          }
      }
  
      return $provides;
  }
  
  sub save_meta {
      my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;
  
      return unless $dist->{distvname} && $dist->{source} eq 'cpan';
  
      my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
          ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};
  
      my $provides = $dist->{provides};
  
      File::Path::mkpath("blib/meta", 0, 0777);
  
      my $local = {
          name => $module_name,
          target => $module,
          version => exists $provides->{$module_name}
              ? ($provides->{$module_name}{version} || $dist->{version}) : $dist->{version},
          dist => $dist->{distvname},
          pathname => $dist->{pathname},
          provides => $provides,
      };
  
      require JSON::PP;
      open my $fh, ">", "blib/meta/install.json" or die $!;
      print $fh JSON::PP::encode_json($local);
  
      File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json");
  
      my @cmd = (
          ($self->{sudo} ? 'sudo' : ()),
          $^X,
          '-MExtUtils::Install=install',
          '-e',
          qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
      );
      $self->run_command(\@cmd);
  }
  
  sub install_base {
      my($self, $mm_opt) = @_;
      $mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;
      die "Your PERL_MM_OPT doesn't contain INSTALL_BASE";
  }
  
  sub configure_features {
      my($self, $dist, @features) = @_;
      map $_->identifier, grep { $self->effective_feature($dist, $_) } @features;
  }
  
  sub effective_feature {
      my($self, $dist, $feature) = @_;
  
      if ($dist->{depth} == 0) {
          my $value = $self->{features}{$feature->identifier};
          return $value if defined $value;
          return 1 if $self->{features}{__all};
      }
  
      if ($self->{interactive}) {
          require CPAN::Meta::Requirements;
  
          $self->diag("[@{[ $feature->description ]}]\n", 1);
  
          my $req = CPAN::Meta::Requirements->new;
          for my $phase (@{$dist->{want_phases}}) {
              for my $type (@{$self->{install_types}}) {
                  $req->add_requirements($feature->prereqs->requirements_for($phase, $type));
              }
          }
  
          my $reqs = $req->as_string_hash;
          my @missing;
          for my $module (keys %$reqs) {
              if ($self->should_install($module, $req->{$module})) {
                  push @missing, $module;
              }
          }
  
          if (@missing) {
              my $howmany = @missing;
              $self->diag("==> Found missing dependencies: " . join(", ", @missing) . "\n", 1);
              local $self->{prompt} = 1;
              return $self->prompt_bool("Install the $howmany optional module(s)?", "y");
          }
      }
  
      return;
  }
  
  sub find_prereqs {
      my($self, $dist) = @_;
  
      my @deps = $self->extract_meta_prereqs($dist);
  
      if ($dist->{module} =~ /^Bundle::/i) {
          push @deps, $self->bundle_deps($dist);
      }
  
      $self->merge_with_cpanfile($dist, \@deps);
  
      return @deps;
  }
  
  sub merge_with_cpanfile {
      my($self, $dist, $deps) = @_;
  
      if ($self->{cpanfile_requirements} && !$dist->{cpanfile}) {
          for my $dep (@$deps) {
              $dep->merge_with($self->{cpanfile_requirements});
          }
      }
  
      if ($self->{cpanfile_global}) {
          for my $dep (@$deps) {
              my $opts = $self->{cpanfile_global}->options_for_module($dep->module)
                or next;
  
              $dep->dist($opts->{dist})     if $opts->{dist};
              $dep->mirror($opts->{mirror}) if $opts->{mirror};
              $dep->url($opts->{url})       if $opts->{url};
          }
      }
  }
  
  sub extract_meta_prereqs {
      my($self, $dist) = @_;
  
      if ($dist->{cpanfile}) {
          my @features = $self->configure_features($dist, $dist->{cpanfile}->features);
          my $prereqs = $dist->{cpanfile}->prereqs_with(@features);
          # TODO: creating requirements is useful even without cpanfile to detect conflicting prereqs
          $self->{cpanfile_requirements} = $prereqs->merged_requirements($dist->{want_phases}, ['requires']);
          return Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
      }
  
      require CPAN::Meta;
  
      my @meta = qw(MYMETA.json MYMETA.yml);
      if ($self->no_dynamic_config($dist->{meta})) {
          push @meta, qw(META.json META.yml);
      }
  
      my @deps;
      my($meta_file) = grep -f, @meta;
      if ($meta_file) {
          $self->chat("Checking dependencies from $meta_file ...\n");
          my $mymeta = eval { CPAN::Meta->load_file($meta_file, { lazy_validation => 1 }) };
          if ($mymeta) {
              $dist->{meta}{name}    = $mymeta->name;
              $dist->{meta}{version} = $mymeta->version;
              return $self->extract_prereqs($mymeta, $dist);
          }
      }
  
      $self->diag_fail("No MYMETA file is found after configure. Your toolchain is too old?");
      return;
  }
  
  sub bundle_deps {
      my($self, $dist) = @_;
  
      my $match;
      if ($dist->{module}) {
          $match = sub {
              my $meta = Module::Metadata->new_from_file($_[0]);
              $meta && ($meta->name eq $dist->{module});
          };
      } else {
          $match = sub { 1 };
      }
  
      my @files;
      File::Find::find({
          wanted => sub {
              push @files, File::Spec->rel2abs($_) if /\.pm$/i && $match->($_);
          },
          no_chdir => 1,
      }, '.');
  
      my @deps;
  
      for my $file (@files) {
          open my $pod, "<", $file or next;
          my $in_contents;
          while (<$pod>) {
              if (/^=head\d\s+CONTENTS/) {
                  $in_contents = 1;
              } elsif (/^=/) {
                  $in_contents = 0;
              } elsif ($in_contents) {
                  /^(\S+)\s*(\S+)?/
                      and push @deps, Menlo::Dependency->new($1, $self->maybe_version($2));
              }
          }
      }
  
      return @deps;
  }
  
  sub maybe_version {
      my($self, $string) = @_;
      return $string && $string =~ /^\.?\d/ ? $string : undef;
  }
  
  sub extract_prereqs {
      my($self, $meta, $dist) = @_;
  
      my @features = $self->configure_features($dist, $meta->features);
      my $prereqs  = $self->soften_makemaker_prereqs($meta->effective_prereqs(\@features)->clone);
  
      return Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
  }
  
  # Workaround for Module::Install 1.04 creating a bogus (higher) MakeMaker requirement that it needs in build_requires
  # Assuming MakeMaker requirement is already satisfied in configure_requires, there's no need to have higher version of
  # MakeMaker in build/test anyway. https://github.com/miyagawa/cpanminus/issues/463
  sub soften_makemaker_prereqs {
      my($self, $prereqs) = @_;
  
      return $prereqs unless -e "inc/Module/Install.pm";
  
      for my $phase (qw( build test runtime )) {
          my $reqs = $prereqs->requirements_for($phase, 'requires');
          if ($reqs->requirements_for_module('ExtUtils::MakeMaker')) {
              $reqs->clear_requirement('ExtUtils::MakeMaker');
              $reqs->add_minimum('ExtUtils::MakeMaker' => 0);
          }
      }
  
      $prereqs;
  }
  
  sub cleanup_workdirs {
      my $self = shift;
  
      my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup};
      my @targets;
  
      opendir my $dh, "$self->{home}/work";
      while (my $e = readdir $dh) {
          next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID}
          my $time = $1;
          if ($time < $expire) {
              push @targets, "$self->{home}/work/$e";
          }
      }
  
      if (@targets) {
          if (@targets >= 64) {
              $self->diag("Expiring " . scalar(@targets) . " work directories. This might take a while...\n");
          } else {
              $self->chat("Expiring " . scalar(@targets) . " work directories.\n");
          }
          File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits
      }
  }
  
  sub scandeps_append_child {
      my($self, $dist) = @_;
  
      my $new_node = [ $dist, [] ];
  
      my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
      push @{$curr_node->[1]}, $new_node;
  
      $self->{scandeps_current} = $new_node;
  
      return sub { $self->{scandeps_current} = $curr_node };
  }
  
  sub dump_scandeps {
      my $self = shift;
  
      if ($self->{format} eq 'tree') {
          $self->walk_down(sub {
              my($dist, $depth) = @_;
              if ($depth == 0) {
                  print "$dist->{distvname}\n";
              } else {
                  print " " x ($depth - 1);
                  print "\\_ $dist->{distvname}\n";
              }
          }, 1);
      } elsif ($self->{format} =~ /^dists?$/) {
          $self->walk_down(sub {
              my($dist, $depth) = @_;
              print $self->format_dist($dist), "\n";
          }, 0);
      } elsif ($self->{format} eq 'json') {
          require JSON::PP;
          print JSON::PP::encode_json($self->{scandeps_tree});
      } elsif ($self->{format} eq 'yaml') {
          require CPAN::Meta::YAML;
          print CPAN::Meta::YAML::Dump($self->{scandeps_tree});
      } else {
          $self->diag("Unknown format: $self->{format}\n");
      }
  }
  
  sub walk_down {
      my($self, $cb, $pre) = @_;
      $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
  }
  
  sub _do_walk_down {
      my($self, $children, $cb, $depth, $pre) = @_;
  
      # DFS - $pre determines when we call the callback
      for my $node (@$children) {
          $cb->($node->[0], $depth) if $pre;
          $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
          $cb->($node->[0], $depth) unless $pre;
      }
  }
  
  sub DESTROY {
      my $self = shift;
      $self->{at_exit}->($self) if $self->{at_exit};
  }
  
  # Utils
  
  sub mirror {
      my($self, $uri, $local) = @_;
      if ($uri =~ /^file:/) {
          $self->file_mirror($uri, $local);
      } else {
          $self->{http}->mirror($uri, $local);
      }
  }
  
  sub untar    { $_[0]->{_backends}{untar}->(@_) };
  sub unzip    { $_[0]->{_backends}{unzip}->(@_) };
  
  sub uri_to_file {
      my($self, $uri) = @_;
  
      # file:///path/to/file -> /path/to/file
      # file://C:/path       -> C:/path
      if ($uri =~ s!file:/+!!) {
          $uri = "/$uri" unless $uri =~ m![a-zA-Z]:!;
      }
  
      return $uri;
  }
  
  sub file_get {
      my($self, $uri) = @_;
      my $file = $self->uri_to_file($uri);
      open my $fh, "<$file" or return;
      join '', <$fh>;
  }
  
  sub file_mirror {
      my($self, $uri, $path) = @_;
      my $file = $self->uri_to_file($uri);
  
      my $source_mtime = (stat $file)[9];
  
      # Don't mirror a file that's already there (like the index)
      return 1 if -e $path && (stat $path)[9] >= $source_mtime;
  
      File::Copy::copy($file, $path);
  
      utime $source_mtime, $source_mtime, $path;
  }
  
  sub configure_http {
      my $self = shift;
  
      require HTTP::Tinyish;
  
      my @try = qw(HTTPTiny);
      unshift @try, 'Wget' if $self->{try_wget};
      unshift @try, 'Curl' if $self->{try_curl};
      unshift @try, 'LWP'  if $self->{try_lwp};
  
      my @protocol = ('http');
      push @protocol, 'https'
        if grep /^https:/, @{$self->{mirrors}};
  
      my $backend;
      for my $try (map "HTTP::Tinyish::$_", @try) {
          if (my $meta = HTTP::Tinyish->configure_backend($try)) {
              if ((grep $try->supports($_), @protocol) == @protocol) {
                  for my $tool (sort keys %$meta){
                      (my $desc = $meta->{$tool}) =~ s/^(.*?)\n.*/$1/s;
                      $self->chat("You have $tool: $desc\n");
                  }
                  $backend = $try;
                  last;
              }
          }
      }
  
      $backend->new(agent => "Menlo/$Menlo::VERSION", verify_SSL => 1);
  }
  
  sub init_tools {
      my $self = shift;
  
      return if $self->{initialized}++;
  
      if ($self->{make} = which($Config{make})) {
          $self->chat("You have make $self->{make}\n");
      }
  
      $self->{http} = $self->configure_http;
  
      my $tar = which('tar');
      my $tar_ver;
      my $maybe_bad_tar = sub { WIN32 || BAD_TAR || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
  
      if ($tar && !$maybe_bad_tar->()) {
          chomp $tar_ver;
          $self->chat("You have $tar: $tar_ver\n");
          $self->{_backends}{untar} = sub {
              my($self, $tarfile) = @_;
  
              my $xf = ($self->{verbose} ? 'v' : '')."xf";
              my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
  
              my($root, @others) = `$tar ${ar}tf $tarfile`
                  or return undef;
  
              FILE: {
                  chomp $root;
                  $root =~ s!^\./!!;
                  $root =~ s{^(.+?)/.*$}{$1};
  
                  if (!length($root)) {
                      # archive had ./ as the first entry, so try again
                      $root = shift(@others);
                      redo FILE if $root;
                  }
              }
  
              system "$tar $ar$xf $tarfile";
              return $root if -d $root;
  
              $self->diag_fail("Bad archive: $tarfile");
              return undef;
          }
      } elsif (    $tar
               and my $gzip = which('gzip')
               and my $bzip2 = which('bzip2')) {
          $self->chat("You have $tar, $gzip and $bzip2\n");
          $self->{_backends}{untar} = sub {
              my($self, $tarfile) = @_;
  
              my $x  = "x" . ($self->{verbose} ? 'v' : '') . "f -";
              my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip;
  
              my($root, @others) = `$ar -dc $tarfile | $tar tf -`
                  or return undef;
  
              FILE: {
                  chomp $root;
                  $root =~ s!^\./!!;
                  $root =~ s{^(.+?)/.*$}{$1};
  
                  if (!length($root)) {
                      # archive had ./ as the first entry, so try again
                      $root = shift(@others);
                      redo FILE if $root;
                  }
              }
  
              system "$ar -dc $tarfile | $tar $x";
              return $root if -d $root;
  
              $self->diag_fail("Bad archive: $tarfile");
              return undef;
          }
      } elsif (eval { require Archive::Tar }) { # uses too much memory!
          $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");
          $self->{_backends}{untar} = sub {
              my $self = shift;
              my $t = Archive::Tar->new($_[0]);
              my($root, @others) = $t->list_files;
              FILE: {
                  $root =~ s!^\./!!;
                  $root =~ s{^(.+?)/.*$}{$1};
  
                  if (!length($root)) {
                      # archive had ./ as the first entry, so try again
                      $root = shift(@others);
                      redo FILE if $root;
                  }
              }
              $t->extract;
              return -d $root ? $root : undef;
          };
      } else {
          $self->{_backends}{untar} = sub {
              die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n";
          };
      }
  
      if (my $unzip = which('unzip')) {
          $self->chat("You have $unzip\n");
          $self->{_backends}{unzip} = sub {
              my($self, $zipfile) = @_;
  
              my $opt = $self->{verbose} ? '' : '-q';
              my(undef, $root, @others) = `$unzip -t $zipfile`
                  or return undef;
              FILE: {
                  chomp $root;
                  if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
                      $root = shift(@others);
                      redo FILE if $root;
                  }
              }
  
              system "$unzip $opt $zipfile";
              return $root if -d $root;
  
              $self->diag_fail("Bad archive: '$root' $zipfile");
              return undef;
          }
      } else {
          $self->{_backends}{unzip} = sub {
              eval { require Archive::Zip }
                  or  die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
              my($self, $file) = @_;
              my $zip = Archive::Zip->new();
              my $status;
              $status = $zip->read($file);
              $self->diag_fail("Read of file '$file' failed")
                  if $status != Archive::Zip::AZ_OK();
              my @members = $zip->members();
              for my $member ( @members ) {
                  my $af = $member->fileName();
                  next if ($af =~ m!^(/|\.\./)!);
                  $status = $member->extractToFileNamed( $af );
                  $self->diag_fail("Extracting of file 'af' from zipfile '$file' failed")
                      if $status != Archive::Zip::AZ_OK();
              }
  
              my ($root) = $zip->membersMatching( qr<^[^/]+/$> );
              $root &&= $root->fileName;
              return -d $root ? $root : undef;
          };
      }
  }
  
  sub mask_uri_passwords {
      my($self, @strings) = @_;
      s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for @strings;
      return @strings;
  }
  
  1;
MENLO_CLI_COMPAT

$fatpacked{"Menlo/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_DEPENDENCY';
  package Menlo::Dependency;
  use strict;
  use CPAN::Meta::Requirements;
  use Class::Tiny qw( module version type original_version dist mirror url );
  
  sub BUILDARGS {
      my($class, $module, $version, $type) = @_;
      return {
          module => $module,
          version => $version,
          type => $type || 'requires',
      };
  }
  
  sub from_prereqs {
      my($class, $prereqs, $phases, $types) = @_;
  
      my @deps;
      for my $type (@$types) {
          push @deps, $class->from_versions(
              $prereqs->merged_requirements($phases, [$type])->as_string_hash,
              $type,
          );
      }
  
      return @deps;
  }
  
  sub from_versions {
      my($class, $versions, $type) = @_;
  
      my @deps;
      while (my($module, $version) = each %$versions) {
          push @deps, $class->new($module, $version, $type)
      }
  
      @deps;
  }
  
  sub merge_with {
      my($self, $requirements) = @_;
  
      # save the original requirement
      $self->original_version($self->version);
  
      # should it clone? not cloning means we upgrade root $requirements on our way
      eval {
          $requirements->add_string_requirement($self->module, $self->version);
      };
      if ($@ =~ /illegal requirements/) {
          # Just give a warning then replace with the root requirements
          # so that later CPAN::Meta::Check can give a valid error
          warn sprintf("Can't merge requirements for %s: '%s' and '%s'",
                      $self->module, $self->version,
                      $requirements->requirements_for_module($self->module));
      }
  
      $self->version( $requirements->requirements_for_module($self->module) );
  }
  
  sub requires_version {
      my $self = shift;
  
      # original_version may be 0
      if (defined $self->original_version) {
          return $self->original_version;
      }
  
      $self->version;
  }
  
  sub is_requirement {
      $_[0]->type eq 'requires';
  }
  
  1;
MENLO_DEPENDENCY

$fatpacked{"Menlo/Index/MetaCPAN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_INDEX_METACPAN';
  use 5.008001;
  use strict;
  use warnings;
  
  package Menlo::Index::MetaCPAN;
  # ABSTRACT: Search index via MetaCPAN
  # VERSION
  
  use parent 'CPAN::Common::Index';
  
  use Class::Tiny qw/uri include_dev/;
  
  use Carp;
  use HTTP::Tinyish;
  use JSON::PP ();
  use Time::Local ();
  
  sub BUILD {
      my $self = shift;
      my $uri  = $self->uri;
      $uri = "https://fastapi.metacpan.org/v1/download_url/"
        unless defined $uri;
      # ensure URI ends in '/'
      $uri =~ s{/?$}{/};
      $self->uri($uri);
      return;
  }
  
  sub search_packages {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_packages must be hash reference")
        unless ref $args eq 'HASH';
  
      my $range;
      if ( $args->{version} ) {
          $range = "== $args->{version}";
      } elsif ( $args->{version_range} ) {
          $range = $args->{version_range};
      }
      my %query = (
          ($self->include_dev ? (dev => 1) : ()),
          ($range ? (version => $range) : ()),
      );
      my $query = join "&", map { "$_=" . $self->_uri_escape($query{$_}) } sort keys %query;
  
      my $uri = $self->uri . $args->{package} . ($query ? "?$query" : "");
      my $res = HTTP::Tinyish->new->get($uri);
      return unless $res->{success};
  
      my $dist_meta = eval { JSON::PP::decode_json($res->{content}) };
      if ($dist_meta && $dist_meta->{download_url}) {
          (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/\w/\w\w/!!;
  
          return {
              package => $args->{package},
              version => $dist_meta->{version},
              uri => "cpan:///distfile/$distfile",
              download_uri => $self->_download_uri("http://cpan.metacpan.org", $distfile),
          };
      }
  
      return;
  }
  
  sub _parse_date {
      my($self, $date) = @_;
      my @date = $date =~ /^(\d{4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)$/;
      Time::Local::timegm($date[5], $date[4], $date[3], $date[2], $date[1] - 1, $date[0] - 1900);
  }
  
  sub _uri_escape {
      my($self, $string) = @_;
      $string =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
      $string;
  }
  
  sub _download_uri {
      my($self, $base, $distfile) = @_;
      join "/", $base, "authors/id", substr($distfile, 0, 1), substr($distfile, 0, 2), $distfile;
  }
  
  sub index_age { return time }    # pretend always current
  
  sub search_authors { return }    # not supported
  
  1;
  
  =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
  
  =head1 SYNOPSIS
  
    use CPAN::Common::Index::MetaCPAN;
  
    $index = CPAN::Common::Index::MetaCPAN->new({ include_dev => 1 });
    $index->search_packages({ package => "Moose", version => "1.1" });
    $index->search_packages({ package => "Moose", version_range => ">= 1.1, < 2" });
  
  =head1 DESCRIPTION
  
  This module implements a CPAN::Common::Index that searches for packages against
  the MetaCPAN API.
  
  This backend supports searching modules with a version range (as
  specified in L<CPAN::Meta::Spec>) which is translated into MetaCPAN
  search query.
  
  There is also a support for I<dev> release search, by passing
  C<include_dev> parameter to the index object.
  
  The result may include an optional field C<download_uri> which
  suggests a specific mirror URL to download from, which can be
  C<backpan.org> if the archive was deleted, or C<cpan.metacpan.org> if
  the release date is within 1 day (because some mirrors might not have
  synced it yet).
  
  There is no support for searching packages with a regular expression, nor searching authors.
  
  =cut
  
  # vim: ts=4 sts=4 sw=4 et:
MENLO_INDEX_METACPAN

$fatpacked{"Menlo/Index/MetaDB.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_INDEX_METADB';
  use 5.008001;
  use strict;
  use warnings;
  
  package Menlo::Index::MetaDB;
  # ABSTRACT: Search index via CPAN MetaDB
  
  our $VERSION = '0.007';
  
  use parent 'CPAN::Common::Index';
  
  use Class::Tiny qw/uri/;
  
  use Carp;
  use CPAN::Meta::YAML;
  use CPAN::Meta::Requirements;
  use HTTP::Tiny;
  
  sub BUILD {
      my $self = shift;
      my $uri  = $self->uri;
      $uri = "http://cpanmetadb.plackperl.org/v1.0/"
        unless defined $uri;
      # ensure URI ends in '/'
      $uri =~ s{/?$}{/};
      $self->uri($uri);
      return;
  }
  
  sub search_packages {
      my ( $self, $args ) = @_;
      Carp::croak("Argument to search_packages must be hash reference")
        unless ref $args eq 'HASH';
  
      return
        unless exists $args->{package} && ref $args->{package} eq '';
  
      my $mod = $args->{package};
  
      if ($args->{version} || $args->{version_range}) {
          my $res = HTTP::Tiny->new->get( $self->uri . "history/$mod" );
          return unless $res->{success};
  
          my $range = defined $args->{version} ? "== $args->{version}" : $args->{version_range};
          my $reqs = CPAN::Meta::Requirements->from_string_hash({ $mod => $range });
  
          my @found;
          for my $line ( split /\r?\n/, $res->{content} ) {
              if ($line =~ /^$mod\s+(\S+)\s+(\S+)$/) {
                  push @found, {
                      version => $1,
                      version_o => version::->parse($1),
                      distfile => $2,
                  };
              }
          }
  
          return unless @found;
          $found[-1]->{latest} = 1;
  
          my $match;
          for my $try (sort { $b->{version_o} <=> $a->{version_o} } @found) {
              if ($reqs->accepts_module($mod => $try->{version_o})) {
                  $match = $try, last;
              }
          }
  
          if ($match) {
              my $file = $match->{distfile};
              $file =~ s{^./../}{}; # strip leading
              return {
                  package => $mod,
                  version => $match->{version},
                  uri     => "cpan:///distfile/$file",
                  ($match->{latest} ? () :
                     (download_uri => "http://backpan.perl.org/authors/id/$match->{distfile}")),
              };
          }
      } else {
          my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
          return unless $res->{success};
  
          if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
              my $meta = $yaml->[0];
              if ( $meta && $meta->{distfile} ) {
                  my $file = $meta->{distfile};
                  $file =~ s{^./../}{}; # strip leading
                  return {
                      package => $mod,
                      version => $meta->{version},
                      uri     => "cpan:///distfile/$file",
                  };
              }
          }
      }
  
      return;
  }
  
  sub index_age { return time };    # pretend always current
  
  sub search_authors { return };    # not supported
  
  1;
  
  =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
  
  =head1 SYNOPSIS
  
    use CPAN::Common::Index::MetaDB;
  
    $index = CPAN::Common::Index::MetaDB->new;
  
    $index->search_packages({ package => "Moose" });
    $index->search_packages({ package => "Moose", version_range => ">= 2.0" });
  
  =head1 DESCRIPTION
  
  This module implements a CPAN::Common::Index that searches for packages against
  the same CPAN MetaDB API used by L<cpanminus>.
  
  There is no support for advanced package queries or searching authors.  It just
  takes a package name and returns the corresponding version and distribution.
  
  =cut
  
  # vim: ts=4 sts=4 sw=4 et:
MENLO_INDEX_METADB

$fatpacked{"Menlo/Index/Mirror.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_INDEX_MIRROR';
  package Menlo::Index::Mirror;
  use strict;
  use parent qw(CPAN::Common::Index::Mirror);
  use Class::Tiny qw(fetcher);
  
  use File::Basename ();
  use File::Spec ();
  use URI ();
  
  our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
  
  my %INDICES = (
  #    mailrc   => 'authors/01mailrc.txt.gz',
      packages => 'modules/02packages.details.txt.gz',
  );
  
  sub refresh_index {
      my $self = shift;
      for my $file ( values %INDICES ) {
          my $remote = URI->new_abs( $file, $self->mirror );
          $remote =~ s/\.gz$//
            unless $HAS_IO_UNCOMPRESS_GUNZIP;
          my $local = File::Spec->catfile( $self->cache, File::Basename::basename($file) );
          $self->fetcher->($remote, $local)
            or Carp::croak( "Cannot fetch $remote to $local");
          if ($HAS_IO_UNCOMPRESS_GUNZIP) {
              ( my $uncompressed = $local ) =~ s/\.gz$//;
              IO::Uncompress::Gunzip::gunzip( $local, $uncompressed )
                or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
          }
      }
  }
  
  1;
MENLO_INDEX_MIRROR

$fatpacked{"Menlo/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_UTIL';
  package Menlo::Util;
  use strict;
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT_OK = qw(WIN32);
  
  use constant WIN32 => $^O eq 'MSWin32';
  
  if (WIN32) {
      require Win32::ShellQuote;
      *shell_quote = \&Win32::ShellQuote::quote_native;
  } else {
      require String::ShellQuote;
      *shell_quote = \&String::ShellQuote::shell_quote_best_effort;
  }
  
  1;
  
MENLO_UTIL

$fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE';
  package Module::CPANfile;
  use strict;
  use warnings;
  use Cwd;
  use Carp ();
  use Module::CPANfile::Environment;
  use Module::CPANfile::Requirement;
  
  our $VERSION = '1.1002';
  
  BEGIN {
      if (${^TAINT}) {
          *untaint = sub {
              my $str = shift;
              ($str) = $str =~ /^(.+)$/s;
              $str;
          };
      } else {
          *untaint = sub { $_[0] };
      }
  }
  
  sub new {
      my($class, $file) = @_;
      bless {}, $class;
  }
  
  sub load {
      my($proto, $file) = @_;
  
      my $self = ref $proto ? $proto : $proto->new;
      $self->parse($file || _default_cpanfile());
      $self;
  }
  
  sub save {
      my($self, $path) = @_;
  
      open my $out, ">", $path or die "$path: $!";
      print {$out} $self->to_string;
  }
  
  sub parse {
      my($self, $file) = @_;
  
      my $code = do {
          open my $fh, "<", $file or die "$file: $!";
          join '', <$fh>;
      };
  
      $code = untaint $code;
  
      my $env = Module::CPANfile::Environment->new($file);
      $env->parse($code) or die $@;
  
      $self->{_mirrors} = $env->mirrors;
      $self->{_prereqs} = $env->prereqs;
  }
  
  sub from_prereqs {
      my($proto, $prereqs) = @_;
  
      my $self = $proto->new;
      $self->{_prereqs} = Module::CPANfile::Prereqs->from_cpan_meta($prereqs);
  
      $self;
  }
  
  sub mirrors {
      my $self = shift;
      $self->{_mirrors} || [];
  }
  
  sub features {
      my $self = shift;
      map $self->feature($_), $self->{_prereqs}->identifiers;
  }
  
  sub feature {
      my($self, $identifier) = @_;
      $self->{_prereqs}->feature($identifier);
  }
  
  sub prereq { shift->prereqs }
  
  sub prereqs {
      my $self = shift;
      $self->{_prereqs}->as_cpan_meta;
  }
  
  sub merged_requirements {
      my $self = shift;
      $self->{_prereqs}->merged_requirements;
  }
  
  sub effective_prereqs {
      my($self, $features) = @_;
      $self->prereqs_with(@{$features || []});
  }
  
  sub prereqs_with {
      my($self, @feature_identifiers) = @_;
  
      my $prereqs = $self->prereqs;
      my @others = map { $self->feature($_)->prereqs } @feature_identifiers;
  
      $prereqs->with_merged_prereqs(\@others);
  }
  
  sub prereq_specs {
      my $self = shift;
      $self->prereqs->as_string_hash;
  }
  
  sub prereq_for_module {
      my($self, $module) = @_;
      $self->{_prereqs}->find($module);
  }
  
  sub options_for_module {
      my($self, $module) = @_;
      my $prereq = $self->prereq_for_module($module) or return;
      $prereq->requirement->options;
  }
  
  sub merge_meta {
      my($self, $file, $version) = @_;
  
      require CPAN::Meta;
  
      $version ||= $file =~ /\.yml$/ ? '1.4' : '2';
  
      my $prereq = $self->prereqs;
  
      my $meta = CPAN::Meta->load_file($file);
      my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;
      my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash };
  
      CPAN::Meta->new($struct)->save($file, { version => $version });
  }
  
  sub _dump {
      my $str = shift;
      require Data::Dumper;
      chomp(my $value = Data::Dumper->new([$str])->Terse(1)->Dump);
      $value;
  }
  
  sub _default_cpanfile {
      my $file = Cwd::abs_path('cpanfile');
      untaint $file;
  }
  
  sub to_string {
      my($self, $include_empty) = @_;
  
      my $mirrors = $self->mirrors;
      my $prereqs = $self->prereq_specs;
  
      my $code = '';
      $code .= $self->_dump_mirrors($mirrors);
      $code .= $self->_dump_prereqs($prereqs, $include_empty);
  
      for my $feature ($self->features) {
          $code .= sprintf "feature %s, %s => sub {\n", _dump($feature->{identifier}), _dump($feature->{description});
          $code .= $self->_dump_prereqs($feature->{spec}, $include_empty, 4);
          $code .= "}\n\n";
      }
  
      $code =~ s/\n+$/\n/s;
      $code;
  }
  
  sub _dump_mirrors {
      my($self, $mirrors) = @_;
  
      my $code = "";
  
      for my $url (@$mirrors) {
          $code .= "mirror '$url';\n";
      }
  
      $code =~ s/\n+$/\n/s;
      $code;
  }
  
  sub _dump_prereqs {
      my($self, $prereqs, $include_empty, $base_indent) = @_;
  
      my $code = '';
      for my $phase (qw(runtime configure build test develop)) {
          my $indent = $phase eq 'runtime' ? '' : '    ';
          $indent = (' ' x ($base_indent || 0)) . $indent;
  
          my($phase_code, $requirements);
          $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime';
  
          for my $type (qw(requires recommends suggests conflicts)) {
              for my $mod (sort keys %{$prereqs->{$phase}{$type}}) {
                  my $ver = $prereqs->{$phase}{$type}{$mod};
                  $phase_code .= $ver eq '0'
                               ? "${indent}$type '$mod';\n"
                               : "${indent}$type '$mod', '$ver';\n";
                  $requirements++;
              }
          }
  
          $phase_code .= "\n" unless $requirements;
          $phase_code .= "};\n" unless $phase eq 'runtime';
  
          $code .= $phase_code . "\n" if $requirements or $include_empty;
      }
  
      $code =~ s/\n+$/\n/s;
      $code;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Module::CPANfile - Parse cpanfile
  
  =head1 SYNOPSIS
  
    use Module::CPANfile;
  
    my $file = Module::CPANfile->load("cpanfile");
    my $prereqs = $file->prereqs; # CPAN::Meta::Prereqs object
  
    my @features = $file->features; # CPAN::Meta::Feature objects
    my $merged_prereqs = $file->prereqs_with(@identifiers); # CPAN::Meta::Prereqs
  
    $file->merge_meta('MYMETA.json');
  
  =head1 DESCRIPTION
  
  Module::CPANfile is a tool to handle L<cpanfile> format to load application
  specific dependencies, not just for CPAN distributions.
  
  =head1 METHODS
  
  =over 4
  
  =item load
  
    $file = Module::CPANfile->load;
    $file = Module::CPANfile->load('cpanfile');
  
  Load and parse a cpanfile. By default it tries to load C<cpanfile> in
  the current directory, unless you pass the path to its argument.
  
  =item from_prereqs
  
    $file = Module::CPANfile->from_prereqs({
      runtime => { requires => { DBI => '1.000' } },
    });
  
  Creates a new Module::CPANfile object from prereqs hash you can get
  via L<CPAN::Meta>'s C<prereqs>, or L<CPAN::Meta::Prereqs>'
  C<as_string_hash>.
  
    # read MYMETA, then feed the prereqs to create Module::CPANfile
    my $meta = CPAN::Meta->load_file('MYMETA.json');
    my $file = Module::CPANfile->from_prereqs($meta->prereqs);
  
    # load cpanfile, then recreate it with round-trip
    my $file = Module::CPANfile->load('cpanfile');
    $file = Module::CPANfile->from_prereqs($file->prereq_specs);
                                      # or $file->prereqs->as_string_hash
  
  =item prereqs
  
  Returns L<CPAN::Meta::Prereqs> object out of the parsed cpanfile.
  
  =item prereq_specs
  
  Returns a hash reference that should be passed to C<< CPAN::Meta::Prereqs->new >>.
  
  =item features
  
  Returns a list of features available in the cpanfile as L<CPAN::Meta::Feature>.
  
  =item prereqs_with(@identifiers), effective_prereqs(\@identifiers)
  
  Returns L<CPAN::Meta::Prereqs> object, with merged prereqs for
  features identified with the C<@identifiers>.
  
  =item to_string($include_empty)
  
    $file->to_string;
    $file->to_string(1);
  
  Returns a canonical string (code) representation for cpanfile. Useful
  if you want to convert L<CPAN::Meta::Prereqs> to a new cpanfile.
  
    # read MYMETA's prereqs and print cpanfile representation of it
    my $meta = CPAN::Meta->load_file('MYMETA.json');
    my $file = Module::CPANfile->from_prereqs($meta->prereqs);
    print $file->to_string;
  
  By default, it omits the phase where there're no modules
  registered. If you pass the argument of a true value, it will print
  them as well.
  
  =item save
  
    $file->save('cpanfile');
  
  Saves the currently loaded prereqs as a new C<cpanfile> by calling
  C<to_string>. Beware B<this method will overwrite the existing
  cpanfile without any warning or backup>. Taking a backup or giving
  warnings to users is a caller's responsibility.
  
    # Read MYMETA.json and creates a new cpanfile
    my $meta = CPAN::Meta->load_file('MYMETA.json');
    my $file = Module::CPANfile->from_prereqs($meta->prereqs);
    $file->save('cpanfile');
  
  =item merge_meta
  
    $file->merge_meta('META.yml');
    $file->merge_meta('MYMETA.json', '2.0');
  
  Merge the effective prereqs with Meta specification loaded from the
  given META file, using CPAN::Meta. You can specify the META spec
  version in the second argument, which defaults to 1.4 in case the
  given file is YAML, and 2 if it is JSON.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<cpanfile>, L<CPAN::Meta>, L<CPAN::Meta::Spec>
  
  =cut
MODULE_CPANFILE

$fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT';
  package Module::CPANfile::Environment;
  use strict;
  use warnings;
  use Module::CPANfile::Prereqs;
  use Carp ();
  
  my @bindings = qw(
      on requires recommends suggests conflicts
      feature
      osname
      mirror
      configure_requires build_requires test_requires author_requires
  );
  
  my $file_id = 1;
  
  sub new {
      my($class, $file) = @_;
      bless {
          file     => $file,
          phase    => 'runtime', # default phase
          feature  => undef,
          features => {},
          prereqs  => Module::CPANfile::Prereqs->new,
          mirrors  => [],
      }, $class;
  }
  
  sub bind {
      my $self = shift;
      my $pkg = caller;
  
      for my $binding (@bindings) {
          no strict 'refs';
          *{"$pkg\::$binding"} = sub { $self->$binding(@_) };
      }
  }
  
  sub parse {
      my($self, $code) = @_;
  
      my $err;
      {
          local $@;
          $file_id++;
          $self->_evaluate(<<EVAL);
  package Module::CPANfile::Sandbox$file_id;
  no warnings;
  BEGIN { \$_environment->bind }
  
  # line 1 "$self->{file}"
  $code;
  EVAL
          $err = $@;
      }
  
      if ($err) { die "Parsing $self->{file} failed: $err" };
  
      return 1;
  }
  
  sub _evaluate {
      my $_environment = $_[0];
      eval $_[1];
  }
  
  sub prereqs { $_[0]->{prereqs} }
  
  sub mirrors { $_[0]->{mirrors} }
  
  # DSL goes from here
  
  sub on {
      my($self, $phase, $code) = @_;
      local $self->{phase} = $phase;
      $code->();
  }
  
  sub feature {
      my($self, $identifier, $description, $code) = @_;
  
      # shortcut: feature identifier => sub { ... }
      if (@_ == 3 && ref($description) eq 'CODE') {
          $code = $description;
          $description = $identifier;
      }
  
      unless (ref $description eq '' && ref $code eq 'CODE') {
          Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }");
      }
  
      local $self->{feature} = $identifier;
      $self->prereqs->add_feature($identifier, $description);
  
      $code->();
  }
  
  sub osname { die "TODO" }
  
  sub mirror {
      my($self, $url) = @_;
      push @{$self->{mirrors}}, $url;
  }
  
  sub requirement_for {
      my($self, $module, @args) = @_;
  
      my $requirement = 0;
      $requirement = shift @args if @args % 2;
  
      return Module::CPANfile::Requirement->new(
          name    => $module,
          version => $requirement,
          @args,
      );
  }
  
  sub requires {
      my $self = shift;
      $self->add_prereq(requires => @_);
  }
  
  sub recommends {
      my $self = shift;
      $self->add_prereq(recommends => @_);
  }
  
  sub suggests {
      my $self = shift;
      $self->add_prereq(suggests => @_);
  }
  
  sub conflicts {
      my $self = shift;
      $self->add_prereq(conflicts => @_);
  }
  
  sub add_prereq {
      my($self, $type, $module, @args) = @_;
  
      $self->prereqs->add_prereq(
          feature => $self->{feature},
          phase   => $self->{phase},
          type    => $type,
          module  => $module,
          requirement => $self->requirement_for($module, @args),
      );
  }
  
  # Module::Install compatible shortcuts
  
  sub configure_requires {
      my($self, @args) = @_;
      $self->on(configure => sub { $self->requires(@args) });
  }
  
  sub build_requires {
      my($self, @args) = @_;
      $self->on(build => sub { $self->requires(@args) });
  }
  
  sub test_requires {
      my($self, @args) = @_;
      $self->on(test => sub { $self->requires(@args) });
  }
  
  sub author_requires {
      my($self, @args) = @_;
      $self->on(develop => sub { $self->requires(@args) });
  }
  
  1;
  
MODULE_CPANFILE_ENVIRONMENT

$fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ';
  package Module::CPANfile::Prereq;
  use strict;
  
  sub new {
      my($class, %options) = @_;
      bless \%options, $class;
  }
  
  sub feature { $_[0]->{feature} }
  sub phase   { $_[0]->{phase} }
  sub type    { $_[0]->{type} }
  sub module  { $_[0]->{module} }
  sub requirement { $_[0]->{requirement} }
  
  sub match_feature {
      my($self, $identifier) = @_;
      no warnings 'uninitialized';
      $self->feature eq $identifier;
  }
  
  1;
MODULE_CPANFILE_PREREQ

$fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS';
  package Module::CPANfile::Prereqs;
  use strict;
  use Carp ();
  use CPAN::Meta::Feature;
  use Module::CPANfile::Prereq;
  
  sub from_cpan_meta {
      my($class, $prereqs) = @_;
  
      my $self = $class->new;
  
      for my $phase (keys %$prereqs) {
          for my $type (keys %{ $prereqs->{$phase} }) {
              while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
                  $self->add_prereq(
                      phase => $phase,
                      type  => $type,
                      module => $module,
                      requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement),
                  );
              }
          }
      }
  
      $self;
  }
  
  sub new {
      my $class = shift;
      bless {
          prereqs => [],
          features => {},
      }, $class;
  }
  
  sub add_feature {
      my($self, $identifier, $description) = @_;
      $self->{features}{$identifier} = { description => $description };
  }
  
  sub add_prereq {
      my($self, %args) = @_;
      $self->add( Module::CPANfile::Prereq->new(%args) );
  }
  
  sub add {
      my($self, $prereq) = @_;
      push @{$self->{prereqs}}, $prereq;
  }
  
  sub as_cpan_meta {
      my $self = shift;
      $self->{cpanmeta} ||= $self->build_cpan_meta;
  }
  
  sub build_cpan_meta {
      my($self, $identifier) = @_;
  
      my $prereq_spec = {};
      $self->prereq_each($identifier, sub {
          my $prereq = shift;
          $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version;
      });
  
      CPAN::Meta::Prereqs->new($prereq_spec);
  }
  
  sub prereq_each {
      my($self, $identifier, $code) = @_;
  
      for my $prereq (@{$self->{prereqs}}) {
          next unless $prereq->match_feature($identifier);
          $code->($prereq);
      }
  }
  
  sub merged_requirements {
      my $self = shift;
  
      my $reqs = CPAN::Meta::Requirements->new;
      for my $prereq (@{$self->{prereqs}}) {
          $reqs->add_string_requirement($prereq->module, $prereq->requirement->version);
      }
  
      $reqs;
  }
  
  sub find {
      my($self, $module) = @_;
  
      for my $prereq (@{$self->{prereqs}}) {
          return $prereq if $prereq->module eq $module;
      }
  
      return;
  }
  
  sub identifiers {
      my $self = shift;
      keys %{$self->{features}};
  }
  
  sub feature {
      my($self, $identifier) = @_;
  
      my $data = $self->{features}{$identifier}
        or Carp::croak("Unknown feature '$identifier'");
  
      my $prereqs = $self->build_cpan_meta($identifier);
  
      CPAN::Meta::Feature->new($identifier, {
          description => $data->{description},
          prereqs => $prereqs->as_string_hash,
      });
  }
  
  1;
MODULE_CPANFILE_PREREQS

$fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT';
  package Module::CPANfile::Requirement;
  use strict;
  
  sub new {
      my ($class, %args) = @_;
  
      $args{version} ||= 0;
  
      bless +{
          name    => delete $args{name},
          version => delete $args{version},
          options => \%args,
      }, $class;
  }
  
  sub name    { $_[0]->{name} }
  sub version { $_[0]->{version} }
  
  sub options { $_[0]->{options} }
  
  sub has_options {
      keys %{$_[0]->{options}} > 0;
  }
  
  1;
MODULE_CPANFILE_REQUIREMENT

$fatpacked{"Module/Load.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_LOAD';
  package Module::Load;
  
  $VERSION = '0.32';
  
  use strict;
  use warnings;
  use File::Spec ();
  
  sub import {
      my $who = _who();
      my $h; shift;
  
      {   no strict 'refs';
  
          @_ or (
              *{"${who}::load"} = \&load, # compat to prev version
              *{"${who}::autoload"} = \&autoload,
              return
          );
  
          map { $h->{$_} = () if defined $_ } @_;
  
          (exists $h->{none} or exists $h->{''})
              and shift, last;
  
          ((exists $h->{autoload} and shift,1) or (exists $h->{all} and shift))
              and *{"${who}::autoload"} = \&autoload;
  
          ((exists $h->{load} and shift,1) or exists $h->{all})
              and *{"${who}::load"} = \&load;
  
          ((exists $h->{load_remote} and shift,1) or exists $h->{all})
              and *{"${who}::load_remote"} = \&load_remote;
  
          ((exists $h->{autoload_remote} and shift,1) or exists $h->{all})
              and *{"${who}::autoload_remote"} = \&autoload_remote;
  
      }
  
  }
  
  sub load(*;@){
      goto &_load;
  }
  
  sub autoload(*;@){
      unshift @_, 'autoimport';
      goto &_load;
  }
  
  sub load_remote($$;@){
      my ($dst, $src, @exp) = @_;
  
      eval "package $dst;Module::Load::load('$src', qw/@exp/);";
      $@ && die "$@";
  }
  
  sub autoload_remote($$;@){
      my ($dst, $src, @exp) = @_;
  
      eval "package $dst;Module::Load::autoload('$src', qw/@exp/);";
      $@ && die "$@";
  }
  
  sub _load{
      my $autoimport = $_[0] eq 'autoimport' and shift;
      my $mod = shift or return;
      my $who = _who();
  
      if( _is_file( $mod ) ) {
          require $mod;
      } else {
          LOAD: {
              my $err;
              for my $flag ( qw[1 0] ) {
                  my $file = _to_file( $mod, $flag);
                  eval { require $file };
                  $@ ? $err .= $@ : last LOAD;
              }
              die $err if $err;
          }
      }
  
      ### This addresses #41883: Module::Load cannot import
      ### non-Exporter module. ->import() routines weren't
      ### properly called when load() was used.
  
      {   no strict 'refs';
          my $import;
  
      ((@_ or $autoimport) and (
          $import = $mod->can('import')
          ) and (
          unshift(@_, $mod),
          goto &$import,
          return
          )
      );
      }
  
  }
  
  sub _to_file{
      local $_    = shift;
      my $pm      = shift || '';
  
      ## trailing blanks ignored by default. [rt #69886]
      my @parts = split /::|'/, $_, -1;
      ## make sure that we can't hop out of @INC
      shift @parts if @parts && !$parts[0];
  
      ### because of [perl #19213], see caveats ###
      my $file = $^O eq 'MSWin32'
                      ? join "/", @parts
                      : File::Spec->catfile( @parts );
  
      $file   .= '.pm' if $pm;
  
      ### on perl's before 5.10 (5.9.5@31746) if you require
      ### a file in VMS format, it's stored in %INC in VMS
      ### format. Therefor, better unixify it first
      ### Patch in reply to John Malmbergs patch (as mentioned
      ### above) on p5p Tue 21 Aug 2007 04:55:07
      $file = VMS::Filespec::unixify($file) if $^O eq 'VMS';
  
      return $file;
  }
  
  sub _who { (caller(1))[0] }
  
  sub _is_file {
      local $_ = shift;
      return  /^\./               ? 1 :
              /[^\w:']/           ? 1 :
              undef
      #' silly bbedit..
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Module::Load - runtime require of both modules and files
  
  =head1 SYNOPSIS
  
    use Module::Load;
  
    my $module = 'Data::Dumper';
  
    load Data::Dumper;     # loads that module, but not import any functions
                           # -> cannot use 'Dumper' function
  
    load 'Data::Dumper';   # ditto
    load $module           # tritto
  
    autoload Data::Dumper; # loads that module and imports the default functions
                           # -> can use 'Dumper' function
  
    my $script = 'some/script.pl'
    load $script;
    load 'some/script.pl';  # use quotes because of punctuations
  
    load thing;             # try 'thing' first, then 'thing.pm'
  
    load CGI, ':all';       # like 'use CGI qw[:standard]'
  
  =head1 DESCRIPTION
  
  C<Module::Load> eliminates the need to know whether you are trying
  to require either a file or a module.
  
  If you consult C<perldoc -f require> you will see that C<require> will
  behave differently when given a bareword or a string.
  
  In the case of a string, C<require> assumes you are wanting to load a
  file. But in the case of a bareword, it assumes you mean a module.
  
  This gives nasty overhead when you are trying to dynamically require
  modules at runtime, since you will need to change the module notation
  (C<Acme::Comment>) to a file notation fitting the particular platform
  you are on.
  
  C<Module::Load> eliminates the need for this overhead and will
  just DWYM.
  
  =head2 Difference between C<load> and C<autoload>
  
  C<Module::Load> imports the two functions - C<load> and C<autoload>
  
  C<autoload> imports the default functions automatically,
  but C<load> do not import any functions.
  
  C<autoload> is usable under C<BEGIN{};>.
  
  Both the functions can import the functions that are specified.
  
  Following codes are same.
  
    load File::Spec::Functions, qw/splitpath/;
  
    autoload File::Spec::Functions, qw/splitpath/;
  
  =head1 FUNCTIONS
  
  =over 4
  
  =item load
  
  Loads a specified module.
  
  See L</Rules> for detailed loading rule.
  
  =item autoload
  
  Loads a specified module and imports the default functions.
  
  Except importing the functions, 'autoload' is same as 'load'.
  
  =item load_remote
  
  Loads a specified module to the specified package.
  
    use Module::Load 'load_remote';
  
    my $pkg = 'Other::Package';
  
    load_remote $pkg, 'Data::Dumper'; # load a module to 'Other::Package'
                                      # but do not import 'Dumper' function
  
  A module for loading must be quoted.
  
  Except specifing the package and quoting module name,
  'load_remote' is same as 'load'.
  
  =item autoload_remote
  
  Loads a specified module and imports the default functions to the specified package.
  
    use Module::Load 'autoload_remote';
  
    my $pkg = 'Other::Package';
  
    autoload_remote $pkg, 'Data::Dumper'; # load a module to 'Other::Package'
                                          # and imports 'Dumper' function
  
  A module for loading must be quoted.
  
  Except specifing the package and quoting module name,
  'autoload_remote' is same as 'load_remote'.
  
  =back
  
  =head1 Rules
  
  All functions have the following rules to decide what it thinks
  you want:
  
  =over 4
  
  =item *
  
  If the argument has any characters in it other than those matching
  C<\w>, C<:> or C<'>, it must be a file
  
  =item *
  
  If the argument matches only C<[\w:']>, it must be a module
  
  =item *
  
  If the argument matches only C<\w>, it could either be a module or a
  file. We will try to find C<file.pm> first in C<@INC> and if that
  fails, we will try to find C<file> in @INC.  If both fail, we die with
  the respective error messages.
  
  =back
  
  =head1 IMPORTS THE FUNCTIONS
  
  'load' and 'autoload' are imported by default, but 'load_remote' and
  'autoload_remote' are not imported.
  
  To use 'load_remote' or 'autoload_remote', specify at 'use'.
  
  =over 4
  
  =item "load","autoload","load_remote","autoload_remote"
  
  Imports the selected functions.
  
    # imports 'load' and 'autoload' (default)
    use Module::Load;
  
    # imports 'autoload' only
    use Module::Load 'autoload';
  
    # imports 'autoload' and 'autoload_remote', but don't import 'load';
    use Module::Load qw/autoload autoload_remote/;
  
  =item 'all'
  
  Imports all the functions.
  
    use Module::Load 'all'; # imports load, autoload, load_remote, autoload_remote
  
  =item '','none',undef
  
  Not import any functions (C<load> and C<autoload> are not imported).
  
    use Module::Load '';
  
    use Module::Load 'none';
  
    use Module::Load undef;
  
  =back
  
  =head1 Caveats
  
  Because of a bug in perl (#19213), at least in version 5.6.1, we have
  to hardcode the path separator for a require on Win32 to be C</>, like
  on Unix rather than the Win32 C<\>. Otherwise perl will not read its
  own %INC accurately double load files if they are required again, or
  in the worst case, core dump.
  
  C<Module::Load> cannot do implicit imports, only explicit imports.
  (in other words, you always have to specify explicitly what you wish
  to import from a module, even if the functions are in that modules'
  C<@EXPORT>)
  
  =head1 ACKNOWLEDGEMENTS
  
  Thanks to Jonas B. Nielsen for making explicit imports work.
  
  =head1 BUG REPORTS
  
  Please report bugs or other issues to E<lt>bug-module-load@rt.cpan.org<gt>.
  
  =head1 AUTHOR
  
  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
  
  =head1 COPYRIGHT
  
  This library is free software; you may redistribute and/or modify it
  under the same terms as Perl itself.
  
  =cut
MODULE_LOAD

$fatpacked{"Module/Load/Conditional.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_LOAD_CONDITIONAL';
  package Module::Load::Conditional;
  
  use strict;
  
  use Module::Load qw/load autoload_remote/;
  use Params::Check                       qw[check];
  use Locale::Maketext::Simple Style  => 'gettext';
  
  use Carp        ();
  use File::Spec  ();
  use FileHandle  ();
  use version;
  
  use Module::Metadata ();
  
  use constant ON_VMS   => $^O eq 'VMS';
  use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
  use constant QUOTE    => do { ON_WIN32 ? q["] : q['] };
  
  BEGIN {
      use vars        qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK $DEPRECATED
                          $FIND_VERSION $ERROR $CHECK_INC_HASH $FORCE_SAFE_INC ];
      use Exporter;
      @ISA            = qw[Exporter];
      $VERSION        = '0.68';
      $VERBOSE        = 0;
      $DEPRECATED     = 0;
      $FIND_VERSION   = 1;
      $CHECK_INC_HASH = 0;
      $FORCE_SAFE_INC = 0;
      @EXPORT_OK      = qw[check_install can_load requires];
  }
  
  =pod
  
  =head1 NAME
  
  Module::Load::Conditional - Looking up module information / loading at runtime
  
  =head1 SYNOPSIS
  
      use Module::Load::Conditional qw[can_load check_install requires];
  
  
      my $use_list = {
              CPANPLUS        => 0.05,
              LWP             => 5.60,
              'Test::More'    => undef,
      };
  
      print can_load( modules => $use_list )
              ? 'all modules loaded successfully'
              : 'failed to load required modules';
  
  
      my $rv = check_install( module => 'LWP', version => 5.60 )
                  or print 'LWP is not installed!';
  
      print 'LWP up to date' if $rv->{uptodate};
      print "LWP version is $rv->{version}\n";
      print "LWP is installed as file $rv->{file}\n";
  
  
      print "LWP requires the following modules to be installed:\n";
      print join "\n", requires('LWP');
  
      ### allow M::L::C to peek in your %INC rather than just
      ### scanning @INC
      $Module::Load::Conditional::CHECK_INC_HASH = 1;
  
      ### reset the 'can_load' cache
      undef $Module::Load::Conditional::CACHE;
  
      ### don't have Module::Load::Conditional issue warnings --
      ### default is '1'
      $Module::Load::Conditional::VERBOSE = 0;
  
      ### The last error that happened during a call to 'can_load'
      my $err = $Module::Load::Conditional::ERROR;
  
  
  =head1 DESCRIPTION
  
  Module::Load::Conditional provides simple ways to query and possibly load any of
  the modules you have installed on your system during runtime.
  
  It is able to load multiple modules at once or none at all if one of
  them was not able to load. It also takes care of any error checking
  and so forth.
  
  =head1 Methods
  
  =head2 $href = check_install( module => NAME [, version => VERSION, verbose => BOOL ] );
  
  C<check_install> allows you to verify if a certain module is installed
  or not. You may call it with the following arguments:
  
  =over 4
  
  =item module
  
  The name of the module you wish to verify -- this is a required key
  
  =item version
  
  The version this module needs to be -- this is optional
  
  =item verbose
  
  Whether or not to be verbose about what it is doing -- it will default
  to $Module::Load::Conditional::VERBOSE
  
  =back
  
  It will return undef if it was not able to find where the module was
  installed, or a hash reference with the following keys if it was able
  to find the file:
  
  =over 4
  
  =item file
  
  Full path to the file that contains the module
  
  =item dir
  
  Directory, or more exact the C<@INC> entry, where the module was
  loaded from.
  
  =item version
  
  The version number of the installed module - this will be C<undef> if
  the module had no (or unparsable) version number, or if the variable
  C<$Module::Load::Conditional::FIND_VERSION> was set to true.
  (See the C<GLOBAL VARIABLES> section below for details)
  
  =item uptodate
  
  A boolean value indicating whether or not the module was found to be
  at least the version you specified. If you did not specify a version,
  uptodate will always be true if the module was found.
  If no parsable version was found in the module, uptodate will also be
  true, since C<check_install> had no way to verify clearly.
  
  See also C<$Module::Load::Conditional::DEPRECATED>, which affects
  the outcome of this value.
  
  =back
  
  =cut
  
  ### this checks if a certain module is installed already ###
  ### if it returns true, the module in question is already installed
  ### or we found the file, but couldn't open it, OR there was no version
  ### to be found in the module
  ### it will return 0 if the version in the module is LOWER then the one
  ### we are looking for, or if we couldn't find the desired module to begin with
  ### if the installed version is higher or equal to the one we want, it will return
  ### a hashref with he module name and version in it.. so 'true' as well.
  sub check_install {
      my %hash = @_;
  
      my $tmpl = {
              version => { default    => '0.0'    },
              module  => { required   => 1        },
              verbose => { default    => $VERBOSE },
      };
  
      my $args;
      unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
          warn loc( q[A problem occurred checking arguments] ) if $VERBOSE;
          return;
      }
  
      my $file     = File::Spec->catfile( split /::/, $args->{module} ) . '.pm';
      my $file_inc = File::Spec::Unix->catfile(
                          split /::/, $args->{module}
                      ) . '.pm';
  
      ### where we store the return value ###
      my $href = {
              file        => undef,
              version     => undef,
              uptodate    => undef,
      };
  
      my $filename;
  
      ### check the inc hash if we're allowed to
      if( $CHECK_INC_HASH ) {
          $filename = $href->{'file'} =
              $INC{ $file_inc } if defined $INC{ $file_inc };
  
          ### find the version by inspecting the package
          if( defined $filename && $FIND_VERSION ) {
              no strict 'refs';
              $href->{version} = ${ "$args->{module}"."::VERSION" };
          }
      }
  
      ### we didn't find the filename yet by looking in %INC,
      ### so scan the dirs
      unless( $filename ) {
  
          local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
  
          DIR: for my $dir ( @INC ) {
  
              my $fh;
  
              if ( ref $dir ) {
                  ### @INC hook -- we invoke it and get the filehandle back
                  ### this is actually documented behaviour as of 5.8 ;)
  
                  my $existed_in_inc = $INC{$file_inc};
  
                  if (UNIVERSAL::isa($dir, 'CODE')) {
                      ($fh) = $dir->($dir, $file);
  
                  } elsif (UNIVERSAL::isa($dir, 'ARRAY')) {
                      ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}})
  
                  } elsif (UNIVERSAL::can($dir, 'INC')) {
                      ($fh) = $dir->INC($file);
                  }
  
                  if (!UNIVERSAL::isa($fh, 'GLOB')) {
                      warn loc(q[Cannot open file '%1': %2], $file, $!)
                              if $args->{verbose};
                      next;
                  }
  
                  $filename = $INC{$file_inc} || $file;
  
                  delete $INC{$file_inc} if not $existed_in_inc;
  
              } else {
                  $filename = File::Spec->catfile($dir, $file);
                  next unless -e $filename;
  
                  $fh = new FileHandle;
                  if (!$fh->open($filename)) {
                      warn loc(q[Cannot open file '%1': %2], $file, $!)
                              if $args->{verbose};
                      next;
                  }
              }
  
              ### store the directory we found the file in
              $href->{dir} = $dir;
  
              ### files need to be in unix format under vms,
              ### or they might be loaded twice
              $href->{file} = ON_VMS
                  ? VMS::Filespec::unixify( $filename )
                  : $filename;
  
              ### if we don't need the version, we're done
              last DIR unless $FIND_VERSION;
  
              ### otherwise, the user wants us to find the version from files
              my $mod_info = Module::Metadata->new_from_handle( $fh, $filename );
              my $ver      = $mod_info->version( $args->{module} );
  
              if( defined $ver ) {
                  $href->{version} = $ver;
  
                  last DIR;
              }
          }
      }
  
      ### if we couldn't find the file, return undef ###
      return unless defined $href->{file};
  
      ### only complain if we're expected to find a version higher than 0.0 anyway
      if( $FIND_VERSION and not defined $href->{version} ) {
          {   ### don't warn about the 'not numeric' stuff ###
              local $^W;
  
              ### if we got here, we didn't find the version
              warn loc(q[Could not check version on '%1'], $args->{module} )
                      if $args->{verbose} and $args->{version} > 0;
          }
          $href->{uptodate} = 1;
  
      } else {
          ### don't warn about the 'not numeric' stuff ###
          local $^W;
  
          ### use qv(), as it will deal with developer release number
          ### ie ones containing _ as well. This addresses bug report
          ### #29348: Version compare logic doesn't handle alphas?
          ###
          ### Update from JPeacock: apparently qv() and version->new
          ### are different things, and we *must* use version->new
          ### here, or things like #30056 might start happening
  
          ### We have to wrap this in an eval as version-0.82 raises
          ### exceptions and not warnings now *sigh*
  
          eval {
  
            $href->{uptodate} =
              version->new( $args->{version} ) <= version->new( $href->{version} )
                  ? 1
                  : 0;
  
          };
      }
  
      if ( $DEPRECATED and "$]" >= 5.011 ) {
          local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
          require Module::CoreList;
          require Config;
  
          $href->{uptodate} = 0 if
             exists $Module::CoreList::version{ 0+$] }{ $args->{module} } and
             Module::CoreList::is_deprecated( $args->{module} ) and
             $Config::Config{privlibexp} eq $href->{dir}
             and $Config::Config{privlibexp} ne $Config::Config{sitelibexp};
      }
  
      return $href;
  }
  
  =head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL, autoload => BOOL] )
  
  C<can_load> will take a list of modules, optionally with version
  numbers and determine if it is able to load them. If it can load *ALL*
  of them, it will. If one or more are unloadable, none will be loaded.
  
  This is particularly useful if you have More Than One Way (tm) to
  solve a problem in a program, and only wish to continue down a path
  if all modules could be loaded, and not load them if they couldn't.
  
  This function uses the C<load> function or the C<autoload_remote> function
  from Module::Load under the hood.
  
  C<can_load> takes the following arguments:
  
  =over 4
  
  =item modules
  
  This is a hashref of module/version pairs. The version indicates the
  minimum version to load. If no version is provided, any version is
  assumed to be good enough.
  
  =item verbose
  
  This controls whether warnings should be printed if a module failed
  to load.
  The default is to use the value of $Module::Load::Conditional::VERBOSE.
  
  =item nocache
  
  C<can_load> keeps its results in a cache, so it will not load the
  same module twice, nor will it attempt to load a module that has
  already failed to load before. By default, C<can_load> will check its
  cache, but you can override that by setting C<nocache> to true.
  
  =item autoload
  
  This controls whether imports the functions of a loaded modules to the caller package. The default is no importing any functions.
  
  See the C<autoload> function and the C<autoload_remote> function from L<Module::Load> for details.
  
  =cut
  
  sub can_load {
      my %hash = @_;
  
      my $tmpl = {
          modules     => { default => {}, strict_type => 1 },
          verbose     => { default => $VERBOSE },
          nocache     => { default => 0 },
          autoload    => { default => 0 },
      };
  
      my $args;
  
      unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
          $ERROR = loc(q[Problem validating arguments!]);
          warn $ERROR if $VERBOSE;
          return;
      }
  
      ### layout of $CACHE:
      ### $CACHE = {
      ###     $ module => {
      ###             usable  => BOOL,
      ###             version => \d,
      ###             file    => /path/to/file,
      ###     },
      ### };
  
      $CACHE ||= {}; # in case it was undef'd
  
      my $error;
      BLOCK: {
          my $href = $args->{modules};
  
          my @load;
          for my $mod ( keys %$href ) {
  
              next if $CACHE->{$mod}->{usable} && !$args->{nocache};
  
              ### else, check if the hash key is defined already,
              ### meaning $mod => 0,
              ### indicating UNSUCCESSFUL prior attempt of usage
  
              ### use qv(), as it will deal with developer release number
              ### ie ones containing _ as well. This addresses bug report
              ### #29348: Version compare logic doesn't handle alphas?
              ###
              ### Update from JPeacock: apparently qv() and version->new
              ### are different things, and we *must* use version->new
              ### here, or things like #30056 might start happening
              if (    !$args->{nocache}
                      && defined $CACHE->{$mod}->{usable}
                      && (version->new( $CACHE->{$mod}->{version}||0 )
                          >= version->new( $href->{$mod} ) )
              ) {
                  $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
                  last BLOCK;
              }
  
              my $mod_data = check_install(
                                      module  => $mod,
                                      version => $href->{$mod}
                                  );
  
              if( !$mod_data or !defined $mod_data->{file} ) {
                  $error = loc(q[Could not find or check module '%1'], $mod);
                  $CACHE->{$mod}->{usable} = 0;
                  last BLOCK;
              }
  
              map {
                  $CACHE->{$mod}->{$_} = $mod_data->{$_}
              } qw[version file uptodate];
  
              push @load, $mod;
          }
  
          for my $mod ( @load ) {
  
              if ( $CACHE->{$mod}->{uptodate} ) {
  
                  local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
  
                  if ( $args->{autoload} ) {
                      my $who = (caller())[0];
                      eval { autoload_remote $who, $mod };
                  } else {
                      eval { load $mod };
                  }
  
                  ### in case anything goes wrong, log the error, the fact
                  ### we tried to use this module and return 0;
                  if( $@ ) {
                      $error = $@;
                      $CACHE->{$mod}->{usable} = 0;
                      last BLOCK;
                  } else {
                      $CACHE->{$mod}->{usable} = 1;
                  }
  
              ### module not found in @INC, store the result in
              ### $CACHE and return 0
              } else {
  
                  $error = loc(q[Module '%1' is not uptodate!], $mod);
                  $CACHE->{$mod}->{usable} = 0;
                  last BLOCK;
              }
          }
  
      } # BLOCK
  
      if( defined $error ) {
          $ERROR = $error;
          Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
          return;
      } else {
          return 1;
      }
  }
  
  =back
  
  =head2 @list = requires( MODULE );
  
  C<requires> can tell you what other modules a particular module
  requires. This is particularly useful when you're intending to write
  a module for public release and are listing its prerequisites.
  
  C<requires> takes but one argument: the name of a module.
  It will then first check if it can actually load this module, and
  return undef if it can't.
  Otherwise, it will return a list of modules and pragmas that would
  have been loaded on the module's behalf.
  
  Note: The list C<require> returns has originated from your current
  perl and your current install.
  
  =cut
  
  sub requires {
      my $who = shift;
  
      unless( check_install( module => $who ) ) {
          warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
          return undef;
      }
  
      local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
  
      my $lib = join " ", map { qq["-I$_"] } @INC;
      my $oneliner = 'print(join(qq[\n],map{qq[BONG=$_]}keys(%INC)),qq[\n])';
      my $cmd = join '', qq["$^X" $lib -M$who -e], QUOTE, $oneliner, QUOTE;
  
      return  sort
                  grep { !/^$who$/  }
                  map  { chomp; s|/|::|g; $_ }
                  grep { s|\.pm$||i; }
                  map  { s!^BONG\=!!; $_ }
                  grep { m!^BONG\=! }
              `$cmd`;
  }
  
  1;
  
  __END__
  
  =head1 Global Variables
  
  The behaviour of Module::Load::Conditional can be altered by changing the
  following global variables:
  
  =head2 $Module::Load::Conditional::VERBOSE
  
  This controls whether Module::Load::Conditional will issue warnings and
  explanations as to why certain things may have failed. If you set it
  to 0, Module::Load::Conditional will not output any warnings.
  The default is 0;
  
  =head2 $Module::Load::Conditional::FIND_VERSION
  
  This controls whether Module::Load::Conditional will try to parse
  (and eval) the version from the module you're trying to load.
  
  If you don't wish to do this, set this variable to C<false>. Understand
  then that version comparisons are not possible, and Module::Load::Conditional
  can not tell you what module version you have installed.
  This may be desirable from a security or performance point of view.
  Note that C<$FIND_VERSION> code runs safely under C<taint mode>.
  
  The default is 1;
  
  =head2 $Module::Load::Conditional::CHECK_INC_HASH
  
  This controls whether C<Module::Load::Conditional> checks your
  C<%INC> hash to see if a module is available. By default, only
  C<@INC> is scanned to see if a module is physically on your
  filesystem, or available via an C<@INC-hook>. Setting this variable
  to C<true> will trust any entries in C<%INC> and return them for
  you.
  
  The default is 0;
  
  =head2 $Module::Load::Conditional::FORCE_SAFE_INC
  
  This controls whether C<Module::Load::Conditional> sanitises C<@INC>
  by removing "C<.>". The current default setting is C<0>, but this
  may change in a future release.
  
  =head2 $Module::Load::Conditional::CACHE
  
  This holds the cache of the C<can_load> function. If you explicitly
  want to remove the current cache, you can set this variable to
  C<undef>
  
  =head2 $Module::Load::Conditional::ERROR
  
  This holds a string of the last error that happened during a call to
  C<can_load>. It is useful to inspect this when C<can_load> returns
  C<undef>.
  
  =head2 $Module::Load::Conditional::DEPRECATED
  
  This controls whether C<Module::Load::Conditional> checks if
  a dual-life core module has been deprecated. If this is set to
  true C<check_install> will return false to C<uptodate>, if
  a dual-life module is found to be loaded from C<$Config{privlibexp}>
  
  The default is 0;
  
  =head1 See Also
  
  C<Module::Load>
  
  =head1 BUG REPORTS
  
  Please report bugs or other issues to E<lt>bug-module-load-conditional@rt.cpan.orgE<gt>.
  
  =head1 AUTHOR
  
  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
  
  =head1 COPYRIGHT
  
  This library is free software; you may redistribute and/or modify it
  under the same terms as Perl itself.
  
  =cut
MODULE_LOAD_CONDITIONAL

$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA';
  # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
  # vim:ts=8:sw=2:et:sta:sts=2:tw=78
  package Module::Metadata; # git description: v1.000032-7-gb4e8a3f
  # ABSTRACT: Gather package and POD information from perl module files
  
  # Adapted from Perl-licensed code originally distributed with
  # Module-Build by Ken Williams
  
  # This module provides routines to gather information about
  # perl modules (assuming this may be expanded in the distant
  # parrot future to look at other types of modules).
  
  sub __clean_eval { eval $_[0] }
  use strict;
  use warnings;
  
  our $VERSION = '1.000033';
  
  use Carp qw/croak/;
  use File::Spec;
  BEGIN {
         # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
         eval {
                 require Fcntl; Fcntl->import('SEEK_SET'); 1;
         } or *SEEK_SET = sub { 0 }
  }
  use version 0.87;
  BEGIN {
    if ($INC{'Log/Contextual.pm'}) {
      require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
      Log::Contextual->import('log_info',
        '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }),
      );
    }
    else {
      *log_info = sub (&) { warn $_[0]->() };
    }
  }
  use File::Find qw(find);
  
  my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
  
  my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
    [a-zA-Z_]                     # the first word CANNOT start with a digit
      (?:
        [\w']?                    # can contain letters, digits, _, or ticks
        \w                        # But, NO multi-ticks or trailing ticks
      )*
  }x;
  
  my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
    \w                           # the 2nd+ word CAN start with digits
      (?:
        [\w']?                   # and can contain letters or ticks
        \w                       # But, NO multi-ticks or trailing ticks
      )*
  }x;
  
  my $PKG_NAME_REGEXP = qr{ # match a package name
    (?: :: )?               # a pkg name can start with arisdottle
    $PKG_FIRST_WORD_REGEXP  # a package word
    (?:
      (?: :: )+             ### arisdottle (allow one or many times)
      $PKG_ADDL_WORD_REGEXP ### a package word
    )*                      # ^ zero, one or many times
    (?:
      ::                    # allow trailing arisdottle
    )?
  }x;
  
  my $PKG_REGEXP  = qr{   # match a package declaration
    ^[\s\{;]*             # intro chars on a line
    package               # the word 'package'
    \s+                   # whitespace
    ($PKG_NAME_REGEXP)    # a package name
    \s*                   # optional whitespace
    ($V_NUM_REGEXP)?        # optional version number
    \s*                   # optional whitesapce
    [;\{]                 # semicolon line terminator or block start (since 5.16)
  }x;
  
  my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
    ([\$*])         # sigil - $ or *
    (
      (             # optional leading package name
        (?:::|\')?  # possibly starting like just :: (a la $::VERSION)
        (?:\w+(?:::|\'))*  # Foo::Bar:: ...
      )?
      VERSION
    )\b
  }x;
  
  my $VERS_REGEXP = qr{ # match a VERSION definition
    (?:
      \(\s*$VARNAME_REGEXP\s*\) # with parens
    |
      $VARNAME_REGEXP           # without parens
    )
    \s*
    =[^=~>]  # = but not ==, nor =~, nor =>
  }x;
  
  sub new_from_file {
    my $class    = shift;
    my $filename = File::Spec->rel2abs( shift );
  
    return undef unless defined( $filename ) && -f $filename;
    return $class->_init(undef, $filename, @_);
  }
  
  sub new_from_handle {
    my $class    = shift;
    my $handle   = shift;
    my $filename = shift;
    return undef unless defined($handle) && defined($filename);
    $filename = File::Spec->rel2abs( $filename );
  
    return $class->_init(undef, $filename, @_, handle => $handle);
  
  }
  
  
  sub new_from_module {
    my $class   = shift;
    my $module  = shift;
    my %props   = @_;
  
    $props{inc} ||= \@INC;
    my $filename = $class->find_module_by_name( $module, $props{inc} );
    return undef unless defined( $filename ) && -f $filename;
    return $class->_init($module, $filename, %props);
  }
  
  {
  
    my $compare_versions = sub {
      my ($v1, $op, $v2) = @_;
      $v1 = version->new($v1)
        unless UNIVERSAL::isa($v1,'version');
  
      my $eval_str = "\$v1 $op \$v2";
      my $result   = eval $eval_str;
      log_info { "error comparing versions: '$eval_str' $@" } if $@;
  
      return $result;
    };
  
    my $normalize_version = sub {
      my ($version) = @_;
      if ( $version =~ /[=<>!,]/ ) { # logic, not just version
        # take as is without modification
      }
      elsif ( ref $version eq 'version' ) { # version objects
        $version = $version->is_qv ? $version->normal : $version->stringify;
      }
      elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
        # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
        $version = "v$version";
      }
      else {
        # leave alone
      }
      return $version;
    };
  
    # separate out some of the conflict resolution logic
  
    my $resolve_module_versions = sub {
      my $packages = shift;
  
      my( $file, $version );
      my $err = '';
        foreach my $p ( @$packages ) {
          if ( defined( $p->{version} ) ) {
            if ( defined( $version ) ) {
              if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
                $err .= "  $p->{file} ($p->{version})\n";
              }
              else {
                # same version declared multiple times, ignore
              }
            }
            else {
              $file    = $p->{file};
              $version = $p->{version};
            }
          }
        $file ||= $p->{file} if defined( $p->{file} );
      }
  
      if ( $err ) {
        $err = "  $file ($version)\n" . $err;
      }
  
      my %result = (
        file    => $file,
        version => $version,
        err     => $err
      );
  
      return \%result;
    };
  
    sub provides {
      my $class = shift;
  
      croak "provides() requires key/value pairs \n" if @_ % 2;
      my %args = @_;
  
      croak "provides() takes only one of 'dir' or 'files'\n"
        if $args{dir} && $args{files};
  
      croak "provides() requires a 'version' argument"
        unless defined $args{version};
  
      croak "provides() does not support version '$args{version}' metadata"
          unless grep { $args{version} eq $_ } qw/1.4 2/;
  
      $args{prefix} = 'lib' unless defined $args{prefix};
  
      my $p;
      if ( $args{dir} ) {
        $p = $class->package_versions_from_directory($args{dir});
      }
      else {
        croak "provides() requires 'files' to be an array reference\n"
          unless ref $args{files} eq 'ARRAY';
        $p = $class->package_versions_from_directory($args{files});
      }
  
      # Now, fix up files with prefix
      if ( length $args{prefix} ) { # check in case disabled with q{}
        $args{prefix} =~ s{/$}{};
        for my $v ( values %$p ) {
          $v->{file} = "$args{prefix}/$v->{file}";
        }
      }
  
      return $p
    }
  
    sub package_versions_from_directory {
      my ( $class, $dir, $files ) = @_;
  
      my @files;
  
      if ( $files ) {
        @files = @$files;
      }
      else {
        find( {
          wanted => sub {
            push @files, $_ if -f $_ && /\.pm$/;
          },
          no_chdir => 1,
        }, $dir );
      }
  
      # First, we enumerate all packages & versions,
      # separating into primary & alternative candidates
      my( %prime, %alt );
      foreach my $file (@files) {
        my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
        my @path = split( /\//, $mapped_filename );
        (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
  
        my $pm_info = $class->new_from_file( $file );
  
        foreach my $package ( $pm_info->packages_inside ) {
          next if $package eq 'main';  # main can appear numerous times, ignore
          next if $package eq 'DB';    # special debugging package, ignore
          next if grep /^_/, split( /::/, $package ); # private package, ignore
  
          my $version = $pm_info->version( $package );
  
          $prime_package = $package if lc($prime_package) eq lc($package);
          if ( $package eq $prime_package ) {
            if ( exists( $prime{$package} ) ) {
              croak "Unexpected conflict in '$package'; multiple versions found.\n";
            }
            else {
              $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
              $prime{$package}{file} = $mapped_filename;
              $prime{$package}{version} = $version if defined( $version );
            }
          }
          else {
            push( @{$alt{$package}}, {
                                      file    => $mapped_filename,
                                      version => $version,
                                     } );
          }
        }
      }
  
      # Then we iterate over all the packages found above, identifying conflicts
      # and selecting the "best" candidate for recording the file & version
      # for each package.
      foreach my $package ( keys( %alt ) ) {
        my $result = $resolve_module_versions->( $alt{$package} );
  
        if ( exists( $prime{$package} ) ) { # primary package selected
  
          if ( $result->{err} ) {
          # Use the selected primary package, but there are conflicting
          # errors among multiple alternative packages that need to be
          # reported
            log_info {
              "Found conflicting versions for package '$package'\n" .
              "  $prime{$package}{file} ($prime{$package}{version})\n" .
              $result->{err}
            };
  
          }
          elsif ( defined( $result->{version} ) ) {
          # There is a primary package selected, and exactly one
          # alternative package
  
          if ( exists( $prime{$package}{version} ) &&
               defined( $prime{$package}{version} ) ) {
            # Unless the version of the primary package agrees with the
            # version of the alternative package, report a conflict
          if ( $compare_versions->(
                   $prime{$package}{version}, '!=', $result->{version}
                 )
               ) {
  
              log_info {
                "Found conflicting versions for package '$package'\n" .
                "  $prime{$package}{file} ($prime{$package}{version})\n" .
                "  $result->{file} ($result->{version})\n"
              };
            }
  
          }
          else {
            # The prime package selected has no version so, we choose to
            # use any alternative package that does have a version
            $prime{$package}{file}    = $result->{file};
            $prime{$package}{version} = $result->{version};
          }
  
          }
          else {
          # no alt package found with a version, but we have a prime
          # package so we use it whether it has a version or not
          }
  
        }
        else { # No primary package was selected, use the best alternative
  
          if ( $result->{err} ) {
            log_info {
              "Found conflicting versions for package '$package'\n" .
              $result->{err}
            };
          }
  
          # Despite possible conflicting versions, we choose to record
          # something rather than nothing
          $prime{$package}{file}    = $result->{file};
          $prime{$package}{version} = $result->{version}
            if defined( $result->{version} );
        }
      }
  
      # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
      # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
      for (grep defined $_->{version}, values %prime) {
        $_->{version} = $normalize_version->( $_->{version} );
      }
  
      return \%prime;
    }
  }
  
  
  sub _init {
    my $class    = shift;
    my $module   = shift;
    my $filename = shift;
    my %props = @_;
  
    my $handle = delete $props{handle};
    my( %valid_props, @valid_props );
    @valid_props = qw( collect_pod inc );
    @valid_props{@valid_props} = delete( @props{@valid_props} );
    warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
  
    my %data = (
      module       => $module,
      filename     => $filename,
      version      => undef,
      packages     => [],
      versions     => {},
      pod          => {},
      pod_headings => [],
      collect_pod  => 0,
  
      %valid_props,
    );
  
    my $self = bless(\%data, $class);
  
    if ( not $handle ) {
      my $filename = $self->{filename};
      open $handle, '<', $filename
        or croak( "Can't open '$filename': $!" );
  
      $self->_handle_bom($handle, $filename);
    }
    $self->_parse_fh($handle);
  
    @{$self->{packages}} = __uniq(@{$self->{packages}});
  
    unless($self->{module} and length($self->{module})) {
      # CAVEAT (possible TODO): .pmc files not treated the same as .pm
      if ($self->{filename} =~ /\.pm$/) {
        my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
        $f =~ s/\..+$//;
        my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
        $self->{module} = shift(@candidates); # this may be undef
      }
      else {
        # this seems like an atrocious heuristic, albeit marginally better than
        # what was here before. It should be rewritten entirely to be more like
        # "if it's not a .pm file, it's not require()able as a name, therefore
        # name() should be undef."
        if ((grep /main/, @{$self->{packages}})
            or (grep /main/, keys %{$self->{versions}})) {
          $self->{module} = 'main';
        }
        else {
          # TODO: this should maybe default to undef instead
          $self->{module} = $self->{packages}[0] || '';
        }
      }
    }
  
    $self->{version} = $self->{versions}{$self->{module}}
      if defined( $self->{module} );
  
    return $self;
  }
  
  # class method
  sub _do_find_module {
    my $class   = shift;
    my $module  = shift || croak 'find_module_by_name() requires a package name';
    my $dirs    = shift || \@INC;
  
    my $file = File::Spec->catfile(split( /::/, $module));
    foreach my $dir ( @$dirs ) {
      my $testfile = File::Spec->catfile($dir, $file);
      return [ File::Spec->rel2abs( $testfile ), $dir ]
        if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
      # CAVEAT (possible TODO): .pmc files are not discoverable here
      $testfile .= '.pm';
      return [ File::Spec->rel2abs( $testfile ), $dir ]
        if -e $testfile;
    }
    return;
  }
  
  # class method
  sub find_module_by_name {
    my $found = shift()->_do_find_module(@_) or return;
    return $found->[0];
  }
  
  # class method
  sub find_module_dir_by_name {
    my $found = shift()->_do_find_module(@_) or return;
    return $found->[1];
  }
  
  
  # given a line of perl code, attempt to parse it if it looks like a
  # $VERSION assignment, returning sigil, full name, & package name
  sub _parse_version_expression {
    my $self = shift;
    my $line = shift;
  
    my( $sigil, $variable_name, $package);
    if ( $line =~ /$VERS_REGEXP/o ) {
      ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
      if ( $package ) {
        $package = ($package eq '::') ? 'main' : $package;
        $package =~ s/::$//;
      }
    }
  
    return ( $sigil, $variable_name, $package );
  }
  
  # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
  # If there's one, then skip it and set the :encoding layer appropriately.
  sub _handle_bom {
    my ($self, $fh, $filename) = @_;
  
    my $pos = tell $fh;
    return unless defined $pos;
  
    my $buf = ' ' x 2;
    my $count = read $fh, $buf, length $buf;
    return unless defined $count and $count >= 2;
  
    my $encoding;
    if ( $buf eq "\x{FE}\x{FF}" ) {
      $encoding = 'UTF-16BE';
    }
    elsif ( $buf eq "\x{FF}\x{FE}" ) {
      $encoding = 'UTF-16LE';
    }
    elsif ( $buf eq "\x{EF}\x{BB}" ) {
      $buf = ' ';
      $count = read $fh, $buf, length $buf;
      if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
        $encoding = 'UTF-8';
      }
    }
  
    if ( defined $encoding ) {
      if ( "$]" >= 5.008 ) {
        binmode( $fh, ":encoding($encoding)" );
      }
    }
    else {
      seek $fh, $pos, SEEK_SET
        or croak( sprintf "Can't reset position to the top of '$filename'" );
    }
  
    return $encoding;
  }
  
  sub _parse_fh {
    my ($self, $fh) = @_;
  
    my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
    my( @packages, %vers, %pod, @pod );
    my $package = 'main';
    my $pod_sect = '';
    my $pod_data = '';
    my $in_end = 0;
  
    while (defined( my $line = <$fh> )) {
      my $line_num = $.;
  
      chomp( $line );
  
      # From toke.c : any line that begins by "=X", where X is an alphabetic
      # character, introduces a POD segment.
      my $is_cut;
      if ( $line =~ /^=([a-zA-Z].*)/ ) {
        my $cmd = $1;
        # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
        # character (which includes the newline, but here we chomped it away).
        $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
        $in_pod = !$is_cut;
      }
  
      if ( $in_pod ) {
  
        if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
          push( @pod, $1 );
          if ( $self->{collect_pod} && length( $pod_data ) ) {
            $pod{$pod_sect} = $pod_data;
            $pod_data = '';
          }
          $pod_sect = $1;
        }
        elsif ( $self->{collect_pod} ) {
          $pod_data .= "$line\n";
        }
        next;
      }
      elsif ( $is_cut ) {
        if ( $self->{collect_pod} && length( $pod_data ) ) {
          $pod{$pod_sect} = $pod_data;
          $pod_data = '';
        }
        $pod_sect = '';
        next;
      }
  
      # Skip after __END__
      next if $in_end;
  
      # Skip comments in code
      next if $line =~ /^\s*#/;
  
      # Would be nice if we could also check $in_string or something too
      if ($line eq '__END__') {
        $in_end++;
        next;
      }
  
      last if $line eq '__DATA__';
  
      # parse $line to see if it's a $VERSION declaration
      my( $version_sigil, $version_fullname, $version_package ) =
        index($line, 'VERSION') >= 1
          ? $self->_parse_version_expression( $line )
          : ();
  
      if ( $line =~ /$PKG_REGEXP/o ) {
        $package = $1;
        my $version = $2;
        push( @packages, $package ) unless grep( $package eq $_, @packages );
        $need_vers = defined $version ? 0 : 1;
  
        if ( not exists $vers{$package} and defined $version ){
          # Upgrade to a version object.
          my $dwim_version = eval { _dwim_version($version) };
          croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
            unless defined $dwim_version;  # "0" is OK!
          $vers{$package} = $dwim_version;
        }
      }
  
      # VERSION defined with full package spec, i.e. $Module::VERSION
      elsif ( $version_fullname && $version_package ) {
        # we do NOT save this package in found @packages
        $need_vers = 0 if $version_package eq $package;
  
        unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
          $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
        }
      }
  
      # first non-comment line in undeclared package main is VERSION
      elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
        $need_vers = 0;
        my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
        $vers{$package} = $v;
        push( @packages, 'main' );
      }
  
      # first non-comment line in undeclared package defines package main
      elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
        $need_vers = 1;
        $vers{main} = '';
        push( @packages, 'main' );
      }
  
      # only keep if this is the first $VERSION seen
      elsif ( $version_fullname && $need_vers ) {
        $need_vers = 0;
        my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
  
        unless ( defined $vers{$package} && length $vers{$package} ) {
          $vers{$package} = $v;
        }
      }
    } # end loop over each line
  
    if ( $self->{collect_pod} && length($pod_data) ) {
      $pod{$pod_sect} = $pod_data;
    }
  
    $self->{versions} = \%vers;
    $self->{packages} = \@packages;
    $self->{pod} = \%pod;
    $self->{pod_headings} = \@pod;
  }
  
  sub __uniq (@)
  {
      my (%seen, $key);
      grep { not $seen{ $key = $_ }++ } @_;
  }
  
  {
  my $pn = 0;
  sub _evaluate_version_line {
    my $self = shift;
    my( $sigil, $variable_name, $line ) = @_;
  
    # We compile into a local sub because 'use version' would cause
    # compiletime/runtime issues with local()
    $pn++; # everybody gets their own package
    my $eval = qq{ my \$dummy = q#  Hide from _packages_inside()
      #; package Module::Metadata::_version::p${pn};
      use version;
      sub {
        local $sigil$variable_name;
        $line;
        return \$$variable_name if defined \$$variable_name;
        return \$Module::Metadata::_version::p${pn}::$variable_name;
      };
    };
  
    $eval = $1 if $eval =~ m{^(.+)}s;
  
    local $^W;
    # Try to get the $VERSION
    my $vsub = __clean_eval($eval);
    # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
    # installed, so we need to hunt in ./lib for it
    if ( $@ =~ /Can't locate/ && -d 'lib' ) {
      local @INC = ('lib',@INC);
      $vsub = __clean_eval($eval);
    }
    warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
      if $@;
  
    (ref($vsub) eq 'CODE') or
      croak "failed to build version sub for $self->{filename}";
  
    my $result = eval { $vsub->() };
    # FIXME: $eval is not the right thing to print here
    croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
      if $@;
  
    # Upgrade it into a version object
    my $version = eval { _dwim_version($result) };
  
    # FIXME: $eval is not the right thing to print here
    croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
      unless defined $version; # "0" is OK!
  
    return $version;
  }
  }
  
  # Try to DWIM when things fail the lax version test in obvious ways
  {
    my @version_prep = (
      # Best case, it just works
      sub { return shift },
  
      # If we still don't have a version, try stripping any
      # trailing junk that is prohibited by lax rules
      sub {
        my $v = shift;
        $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
        return $v;
      },
  
      # Activestate apparently creates custom versions like '1.23_45_01', which
      # cause version.pm to think it's an invalid alpha.  So check for that
      # and strip them
      sub {
        my $v = shift;
        my $num_dots = () = $v =~ m{(\.)}g;
        my $num_unders = () = $v =~ m{(_)}g;
        my $leading_v = substr($v,0,1) eq 'v';
        if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
          $v =~ s{_}{}g;
          $num_unders = () = $v =~ m{(_)}g;
        }
        return $v;
      },
  
      # Worst case, try numifying it like we would have before version objects
      sub {
        my $v = shift;
        no warnings 'numeric';
        return 0 + $v;
      },
  
    );
  
    sub _dwim_version {
      my ($result) = shift;
  
      return $result if ref($result) eq 'version';
  
      my ($version, $error);
      for my $f (@version_prep) {
        $result = $f->($result);
        $version = eval { version->new($result) };
        $error ||= $@ if $@; # capture first failure
        last if defined $version;
      }
  
      croak $error unless defined $version;
  
      return $version;
    }
  }
  
  ############################################################
  
  # accessors
  sub name            { $_[0]->{module}            }
  
  sub filename        { $_[0]->{filename}          }
  sub packages_inside { @{$_[0]->{packages}}       }
  sub pod_inside      { @{$_[0]->{pod_headings}}   }
  sub contains_pod    { 0+@{$_[0]->{pod_headings}} }
  
  sub version {
      my $self = shift;
      my $mod  = shift || $self->{module};
      my $vers;
      if ( defined( $mod ) && length( $mod ) &&
           exists( $self->{versions}{$mod} ) ) {
          return $self->{versions}{$mod};
      }
      else {
          return undef;
      }
  }
  
  sub pod {
      my $self = shift;
      my $sect = shift;
      if ( defined( $sect ) && length( $sect ) &&
           exists( $self->{pod}{$sect} ) ) {
          return $self->{pod}{$sect};
      }
      else {
          return undef;
      }
  }
  
  sub is_indexable {
    my ($self, $package) = @_;
  
    my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside;
  
    # check for specific package, if provided
    return !! grep { $_ eq $package } @indexable_packages if $package;
  
    # otherwise, check for any indexable packages at all
    return !! @indexable_packages;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Module::Metadata - Gather package and POD information from perl module files
  
  =head1 VERSION
  
  version 1.000033
  
  =head1 SYNOPSIS
  
    use Module::Metadata;
  
    # information about a .pm file
    my $info = Module::Metadata->new_from_file( $file );
    my $version = $info->version;
  
    # CPAN META 'provides' field for .pm files in a directory
    my $provides = Module::Metadata->provides(
      dir => 'lib', version => 2
    );
  
  =head1 DESCRIPTION
  
  This module provides a standard way to gather metadata about a .pm file through
  (mostly) static analysis and (some) code execution.  When determining the
  version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
  in the CPAN toolchain.
  
  =head1 CLASS METHODS
  
  =head2 C<< new_from_file($filename, collect_pod => 1) >>
  
  Constructs a C<Module::Metadata> object given the path to a file.  Returns
  undef if the filename does not exist.
  
  C<collect_pod> is a optional boolean argument that determines whether POD
  data is collected and stored for reference.  POD data is not collected by
  default.  POD headings are always collected.
  
  If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
  it is skipped before processing, and the content of the file is also decoded
  appropriately starting from perl 5.8.
  
  =head2 C<< new_from_handle($handle, $filename, collect_pod => 1) >>
  
  This works just like C<new_from_file>, except that a handle can be provided
  as the first argument.
  
  Note that there is no validation to confirm that the handle is a handle or
  something that can act like one.  Passing something that isn't a handle will
  cause a exception when trying to read from it.  The C<filename> argument is
  mandatory or undef will be returned.
  
  You are responsible for setting the decoding layers on C<$handle> if
  required.
  
  =head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
  
  Constructs a C<Module::Metadata> object given a module or package name.
  Returns undef if the module cannot be found.
  
  In addition to accepting the C<collect_pod> argument as described above,
  this method accepts a C<inc> argument which is a reference to an array of
  directories to search for the module.  If none are given, the default is
  @INC.
  
  If the file that contains the module begins by an UTF-8, UTF-16BE or
  UTF-16LE byte-order mark, then it is skipped before processing, and the
  content of the file is also decoded appropriately starting from perl 5.8.
  
  =head2 C<< find_module_by_name($module, \@dirs) >>
  
  Returns the path to a module given the module or package name. A list
  of directories can be passed in as an optional parameter, otherwise
  @INC is searched.
  
  Can be called as either an object or a class method.
  
  =head2 C<< find_module_dir_by_name($module, \@dirs) >>
  
  Returns the entry in C<@dirs> (or C<@INC> by default) that contains
  the module C<$module>. A list of directories can be passed in as an
  optional parameter, otherwise @INC is searched.
  
  Can be called as either an object or a class method.
  
  =head2 C<< provides( %options ) >>
  
  This is a convenience wrapper around C<package_versions_from_directory>
  to generate a CPAN META C<provides> data structure.  It takes key/value
  pairs.  Valid option keys include:
  
  =over
  
  =item version B<(required)>
  
  Specifies which version of the L<CPAN::Meta::Spec> should be used as
  the format of the C<provides> output.  Currently only '1.4' and '2'
  are supported (and their format is identical).  This may change in
  the future as the definition of C<provides> changes.
  
  The C<version> option is required.  If it is omitted or if
  an unsupported version is given, then C<provides> will throw an error.
  
  =item dir
  
  Directory to search recursively for F<.pm> files.  May not be specified with
  C<files>.
  
  =item files
  
  Array reference of files to examine.  May not be specified with C<dir>.
  
  =item prefix
  
  String to prepend to the C<file> field of the resulting output. This defaults
  to F<lib>, which is the common case for most CPAN distributions with their
  F<.pm> files in F<lib>.  This option ensures the META information has the
  correct relative path even when the C<dir> or C<files> arguments are
  absolute or have relative paths from a location other than the distribution
  root.
  
  =back
  
  For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
  is a hashref of the form:
  
    {
      'Package::Name' => {
        version => '0.123',
        file => 'lib/Package/Name.pm'
      },
      'OtherPackage::Name' => ...
    }
  
  =head2 C<< package_versions_from_directory($dir, \@files?) >>
  
  Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
  for those files in C<$dir> - and reads each file for packages and versions,
  returning a hashref of the form:
  
    {
      'Package::Name' => {
        version => '0.123',
        file => 'Package/Name.pm'
      },
      'OtherPackage::Name' => ...
    }
  
  The C<DB> and C<main> packages are always omitted, as are any "private"
  packages that have leading underscores in the namespace (e.g.
  C<Foo::_private>)
  
  Note that the file path is relative to C<$dir> if that is specified.
  This B<must not> be used directly for CPAN META C<provides>.  See
  the C<provides> method instead.
  
  =head2 C<< log_info (internal) >>
  
  Used internally to perform logging; imported from Log::Contextual if
  Log::Contextual has already been loaded, otherwise simply calls warn.
  
  =head1 OBJECT METHODS
  
  =head2 C<< name() >>
  
  Returns the name of the package represented by this module. If there
  is more than one package, it makes a best guess based on the
  filename. If it's a script (i.e. not a *.pm) the package name is
  'main'.
  
  =head2 C<< version($package) >>
  
  Returns the version as defined by the $VERSION variable for the
  package as returned by the C<name> method if no arguments are
  given. If given the name of a package it will attempt to return the
  version of that package if it is specified in the file.
  
  =head2 C<< filename() >>
  
  Returns the absolute path to the file.
  Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle.
  
  =head2 C<< packages_inside() >>
  
  Returns a list of packages. Note: this is a raw list of packages
  discovered (or assumed, in the case of C<main>).  It is not
  filtered for C<DB>, C<main> or private packages the way the
  C<provides> method does.  Invalid package names are not returned,
  for example "Foo:Bar".  Strange but valid package names are
  returned, for example "Foo::Bar::", and are left up to the caller
  on how to handle.
  
  =head2 C<< pod_inside() >>
  
  Returns a list of POD sections.
  
  =head2 C<< contains_pod() >>
  
  Returns true if there is any POD in the file.
  
  =head2 C<< pod($section) >>
  
  Returns the POD data in the given section.
  
  =head2 C<< is_indexable($package) >> or C<< is_indexable() >>
  
  Available since version 1.000020.
  
  Returns a boolean indicating whether the package (if provided) or any package
  (otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server.
  Note This only checks for valid C<package> declarations, and does not take any
  ownership information into account.
  
  =head1 SUPPORT
  
  Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata>
  (or L<bug-Module-Metadata@rt.cpan.org|mailto:bug-Module-Metadata@rt.cpan.org>).
  
  There is also a mailing list available for users of this distribution, at
  L<http://lists.perl.org/list/cpan-workers.html>.
  
  There is also an irc channel available for users of this distribution, at
  L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
  
  =head1 AUTHOR
  
  Original code from Module::Build::ModuleInfo by Ken Williams
  <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
  
  Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
  assistance from David Golden (xdg) <dagolden@cpan.org>.
  
  =head1 CONTRIBUTORS
  
  =for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran Tatsuhiko Miyagawa tokuhirom Kent Fredric Peter Rabbitson Steve Hay Jerry D. Hedden Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass 'BinGOs' Williams Josh Jore
  
  =over 4
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Vincent Pit <perl@profvince.com>
  
  =item *
  
  Matt S Trout <mst@shadowcat.co.uk>
  
  =item *
  
  Chris Nehren <apeiron@cpan.org>
  
  =item *
  
  Graham Knop <haarg@haarg.org>
  
  =item *
  
  Olivier Mengué <dolmen@cpan.org>
  
  =item *
  
  Tomas Doran <bobtfish@bobtfish.net>
  
  =item *
  
  Tatsuhiko Miyagawa <miyagawa@bulknews.net>
  
  =item *
  
  tokuhirom <tokuhirom@gmail.com>
  
  =item *
  
  Kent Fredric <kentnl@cpan.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =item *
  
  Steve Hay <steve.m.hay@googlemail.com>
  
  =item *
  
  Jerry D. Hedden <jdhedden@cpan.org>
  
  =item *
  
  Craig A. Berry <cberry@cpan.org>
  
  =item *
  
  Craig A. Berry <craigberry@mac.com>
  
  =item *
  
  David Mitchell <davem@iabyn.com>
  
  =item *
  
  David Steinbrunner <dsteinbrunner@pobox.com>
  
  =item *
  
  Edward Zborowski <ed@rubensteintech.com>
  
  =item *
  
  Gareth Harper <gareth@broadbean.com>
  
  =item *
  
  James Raspass <jraspass@gmail.com>
  
  =item *
  
  Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
  
  =item *
  
  Josh Jore <jjore@cpan.org>
  
  =back
  
  =head1 COPYRIGHT & LICENSE
  
  Original code Copyright (c) 2001-2011 Ken Williams.
  Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
  All rights reserved.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
MODULE_METADATA

$fatpacked{"Params/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARAMS_CHECK';
  package Params::Check;
  
  use strict;
  
  use Carp                        qw[carp croak];
  use Locale::Maketext::Simple    Style => 'gettext';
  
  BEGIN {
      use Exporter    ();
      use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
                          $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
                          $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
                          $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
                      ];
  
      @ISA        =   qw[ Exporter ];
      @EXPORT_OK  =   qw[check allow last_error];
  
      $VERSION                = '0.38';
      $VERBOSE                = $^W ? 1 : 0;
      $NO_DUPLICATES          = 0;
      $STRIP_LEADING_DASHES   = 0;
      $STRICT_TYPE            = 0;
      $ALLOW_UNKNOWN          = 0;
      $PRESERVE_CASE          = 0;
      $ONLY_ALLOW_DEFINED     = 0;
      $SANITY_CHECK_TEMPLATE  = 1;
      $WARNINGS_FATAL         = 0;
      $CALLER_DEPTH           = 0;
  }
  
  my %known_keys = map { $_ => 1 }
                      qw| required allow default strict_type no_override
                          store defined |;
  
  =pod
  
  =head1 NAME
  
  Params::Check - A generic input parsing/checking mechanism.
  
  =head1 SYNOPSIS
  
      use Params::Check qw[check allow last_error];
  
      sub fill_personal_info {
          my %hash = @_;
          my $x;
  
          my $tmpl = {
              firstname   => { required   => 1, defined => 1 },
              lastname    => { required   => 1, store => \$x },
              gender      => { required   => 1,
                               allow      => [qr/M/i, qr/F/i],
                             },
              married     => { allow      => [0,1] },
              age         => { default    => 21,
                               allow      => qr/^\d+$/,
                             },
  
              phone       => { allow => [ sub { return 1 if /$valid_re/ },
                                          '1-800-PERL' ]
                             },
              id_list     => { default        => [],
                               strict_type    => 1
                             },
              employer    => { default => 'NSA', no_override => 1 },
          };
  
          ### check() returns a hashref of parsed args on success ###
          my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
                              or die qw[Could not parse arguments!];
  
          ... other code here ...
      }
  
      my $ok = allow( $colour, [qw|blue green yellow|] );
  
      my $error = Params::Check::last_error();
  
  
  =head1 DESCRIPTION
  
  Params::Check is a generic input parsing/checking mechanism.
  
  It allows you to validate input via a template. The only requirement
  is that the arguments must be named.
  
  Params::Check can do the following things for you:
  
  =over 4
  
  =item *
  
  Convert all keys to lowercase
  
  =item *
  
  Check if all required arguments have been provided
  
  =item *
  
  Set arguments that have not been provided to the default
  
  =item *
  
  Weed out arguments that are not supported and warn about them to the
  user
  
  =item *
  
  Validate the arguments given by the user based on strings, regexes,
  lists or even subroutines
  
  =item *
  
  Enforce type integrity if required
  
  =back
  
  Most of Params::Check's power comes from its template, which we'll
  discuss below:
  
  =head1 Template
  
  As you can see in the synopsis, based on your template, the arguments
  provided will be validated.
  
  The template can take a different set of rules per key that is used.
  
  The following rules are available:
  
  =over 4
  
  =item default
  
  This is the default value if none was provided by the user.
  This is also the type C<strict_type> will look at when checking type
  integrity (see below).
  
  =item required
  
  A boolean flag that indicates if this argument was a required
  argument. If marked as required and not provided, check() will fail.
  
  =item strict_type
  
  This does a C<ref()> check on the argument provided. The C<ref> of the
  argument must be the same as the C<ref> of the default value for this
  check to pass.
  
  This is very useful if you insist on taking an array reference as
  argument for example.
  
  =item defined
  
  If this template key is true, enforces that if this key is provided by
  user input, its value is C<defined>. This just means that the user is
  not allowed to pass C<undef> as a value for this key and is equivalent
  to:
      allow => sub { defined $_[0] && OTHER TESTS }
  
  =item no_override
  
  This allows you to specify C<constants> in your template. ie, they
  keys that are not allowed to be altered by the user. It pretty much
  allows you to keep all your C<configurable> data in one place; the
  C<Params::Check> template.
  
  =item store
  
  This allows you to pass a reference to a scalar, in which the data
  will be stored:
  
      my $x;
      my $args = check(foo => { default => 1, store => \$x }, $input);
  
  This is basically shorthand for saying:
  
      my $args = check( { foo => { default => 1 }, $input );
      my $x    = $args->{foo};
  
  You can alter the global variable $Params::Check::NO_DUPLICATES to
  control whether the C<store>'d key will still be present in your
  result set. See the L<Global Variables> section below.
  
  =item allow
  
  A set of criteria used to validate a particular piece of data if it
  has to adhere to particular rules.
  
  See the C<allow()> function for details.
  
  =back
  
  =head1 Functions
  
  =head2 check( \%tmpl, \%args, [$verbose] );
  
  This function is not exported by default, so you'll have to ask for it
  via:
  
      use Params::Check qw[check];
  
  or use its fully qualified name instead.
  
  C<check> takes a list of arguments, as follows:
  
  =over 4
  
  =item Template
  
  This is a hash reference which contains a template as explained in the
  C<SYNOPSIS> and C<Template> section.
  
  =item Arguments
  
  This is a reference to a hash of named arguments which need checking.
  
  =item Verbose
  
  A boolean to indicate whether C<check> should be verbose and warn
  about what went wrong in a check or not.
  
  You can enable this program wide by setting the package variable
  C<$Params::Check::VERBOSE> to a true value. For details, see the
  section on C<Global Variables> below.
  
  =back
  
  C<check> will return when it fails, or a hashref with lowercase
  keys of parsed arguments when it succeeds.
  
  So a typical call to check would look like this:
  
      my $parsed = check( \%template, \%arguments, $VERBOSE )
                      or warn q[Arguments could not be parsed!];
  
  A lot of the behaviour of C<check()> can be altered by setting
  package variables. See the section on C<Global Variables> for details
  on this.
  
  =cut
  
  sub check {
      my ($utmpl, $href, $verbose) = @_;
  
      ### clear the current error string ###
      _clear_error();
  
      ### did we get the arguments we need? ###
      if ( !$utmpl or !$href ) {
        _store_error(loc('check() expects two arguments'));
        return unless $WARNINGS_FATAL;
        croak(__PACKAGE__->last_error);
      }
  
      ### sensible defaults ###
      $verbose ||= $VERBOSE || 0;
  
      ### XXX what type of template is it? ###
      ### { key => { } } ?
      #if (ref $args eq 'HASH') {
      #    1;
      #}
  
      ### clean up the template ###
      my $args;
  
      ### don't even bother to loop, if there's nothing to clean up ###
      if( $PRESERVE_CASE and !$STRIP_LEADING_DASHES ) {
          $args = $href;
      } else {
          ### keys are not aliased ###
          for my $key (keys %$href) {
              my $org = $key;
              $key = lc $key unless $PRESERVE_CASE;
              $key =~ s/^-// if $STRIP_LEADING_DASHES;
              $args->{$key} = $href->{$org};
          }
      }
  
      my %defs;
  
      ### which template entries have a 'store' member
      my @want_store;
  
      ### sanity check + defaults + required keys set? ###
      my $fail;
      for my $key (keys %$utmpl) {
          my $tmpl = $utmpl->{$key};
  
          ### check if required keys are provided
          ### keys are now lower cased, unless preserve case was enabled
          ### at which point, the utmpl keys must match, but that's the users
          ### problem.
          if( $tmpl->{'required'} and not exists $args->{$key} ) {
              _store_error(
                  loc(q|Required option '%1' is not provided for %2 by %3|,
                      $key, _who_was_it(), _who_was_it(1)), $verbose );
  
              ### mark the error ###
              $fail++;
              next;
          }
  
          ### next, set the default, make sure the key exists in %defs ###
          $defs{$key} = $tmpl->{'default'}
                          if exists $tmpl->{'default'};
  
          if( $SANITY_CHECK_TEMPLATE ) {
              ### last, check if they provided any weird template keys
              ### -- do this last so we don't always execute this code.
              ### just a small optimization.
              map {   _store_error(
                          loc(q|Template type '%1' not supported [at key '%2']|,
                          $_, $key), 1, 0 );
              } grep {
                  not $known_keys{$_}
              } keys %$tmpl;
  
              ### make sure you passed a ref, otherwise, complain about it!
              if ( exists $tmpl->{'store'} ) {
                  _store_error( loc(
                      q|Store variable for '%1' is not a reference!|, $key
                  ), 1, 0 ) unless ref $tmpl->{'store'};
              }
          }
  
          push @want_store, $key if $tmpl->{'store'};
      }
  
      ### errors found ###
      return if $fail;
  
      ### flag to see if anything went wrong ###
      my $wrong;
  
      ### flag to see if we warned for anything, needed for warnings_fatal
      my $warned;
  
      for my $key (keys %$args) {
          my $arg = $args->{$key};
  
          ### you gave us this key, but it's not in the template ###
          unless( $utmpl->{$key} ) {
  
              ### but we'll allow it anyway ###
              if( $ALLOW_UNKNOWN ) {
                  $defs{$key} = $arg;
  
              ### warn about the error ###
              } else {
                  _store_error(
                      loc("Key '%1' is not a valid key for %2 provided by %3",
                          $key, _who_was_it(), _who_was_it(1)), $verbose);
                  $warned ||= 1;
              }
              next;
          }
  
          ### copy of this keys template instructions, to save derefs ###
          my %tmpl = %{$utmpl->{$key}};
  
          ### check if you're even allowed to override this key ###
          if( $tmpl{'no_override'} ) {
              _store_error(
                  loc(q[You are not allowed to override key '%1'].
                      q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
                  $verbose
              );
              $warned ||= 1;
              next;
          }
  
          ### check if you were supposed to provide defined() values ###
          if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and not defined $arg ) {
              _store_error(loc(q|Key '%1' must be defined when passed|, $key),
                  $verbose );
              $wrong ||= 1;
              next;
          }
  
          ### check if they should be of a strict type, and if it is ###
          if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
              (ref $arg ne ref $tmpl{'default'})
          ) {
              _store_error(loc(q|Key '%1' needs to be of type '%2'|,
                          $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
              $wrong ||= 1;
              next;
          }
  
          ### check if we have an allow handler, to validate against ###
          ### allow() will report its own errors ###
          if( exists $tmpl{'allow'} and not do {
                  local $_ERROR_STRING;
                  allow( $arg, $tmpl{'allow'} )
              }
          ) {
              ### stringify the value in the error report -- we don't want dumps
              ### of objects, but we do want to see *roughly* what we passed
              _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
                               q|provided by %4|,
                              $key, "$arg", _who_was_it(),
                              _who_was_it(1)), $verbose);
              $wrong ||= 1;
              next;
          }
  
          ### we got here, then all must be OK ###
          $defs{$key} = $arg;
  
      }
  
      ### croak with the collected errors if there were errors and
      ### we have the fatal flag toggled.
      croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
  
      ### done with our loop... if $wrong is set, something went wrong
      ### and the user is already informed, just return...
      return if $wrong;
  
      ### check if we need to store any of the keys ###
      ### can't do it before, because something may go wrong later,
      ### leaving the user with a few set variables
      for my $key (@want_store) {
          next unless exists $defs{$key};
          my $ref = $utmpl->{$key}{'store'};
          $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
      }
  
      return \%defs;
  }
  
  =head2 allow( $test_me, \@criteria );
  
  The function that handles the C<allow> key in the template is also
  available for independent use.
  
  The function takes as first argument a key to test against, and
  as second argument any form of criteria that are also allowed by
  the C<allow> key in the template.
  
  You can use the following types of values for allow:
  
  =over 4
  
  =item string
  
  The provided argument MUST be equal to the string for the validation
  to pass.
  
  =item regexp
  
  The provided argument MUST match the regular expression for the
  validation to pass.
  
  =item subroutine
  
  The provided subroutine MUST return true in order for the validation
  to pass and the argument accepted.
  
  (This is particularly useful for more complicated data).
  
  =item array ref
  
  The provided argument MUST equal one of the elements of the array
  ref for the validation to pass. An array ref can hold all the above
  values.
  
  =back
  
  It returns true if the key matched the criteria, or false otherwise.
  
  =cut
  
  sub allow {
      ### use $_[0] and $_[1] since this is hot code... ###
      #my ($val, $ref) = @_;
  
      ### it's a regexp ###
      if( ref $_[1] eq 'Regexp' ) {
          local $^W;  # silence warnings if $val is undef #
          return if $_[0] !~ /$_[1]/;
  
      ### it's a sub ###
      } elsif ( ref $_[1] eq 'CODE' ) {
          return unless $_[1]->( $_[0] );
  
      ### it's an array ###
      } elsif ( ref $_[1] eq 'ARRAY' ) {
  
          ### loop over the elements, see if one of them says the
          ### value is OK
          ### also, short-circuit when possible
          for ( @{$_[1]} ) {
              return 1 if allow( $_[0], $_ );
          }
  
          return;
  
      ### fall back to a simple, but safe 'eq' ###
      } else {
          return unless _safe_eq( $_[0], $_[1] );
      }
  
      ### we got here, no failures ###
      return 1;
  }
  
  ### helper functions ###
  
  sub _safe_eq {
      ### only do a straight 'eq' if they're both defined ###
      return defined($_[0]) && defined($_[1])
                  ? $_[0] eq $_[1]
                  : defined($_[0]) eq defined($_[1]);
  }
  
  sub _who_was_it {
      my $level = $_[0] || 0;
  
      return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
  }
  
  =head2 last_error()
  
  Returns a string containing all warnings and errors reported during
  the last time C<check> was called.
  
  This is useful if you want to report then some other way than
  C<carp>'ing when the verbose flag is on.
  
  It is exported upon request.
  
  =cut
  
  {   $_ERROR_STRING = '';
  
      sub _store_error {
          my($err, $verbose, $offset) = @_[0..2];
          $verbose ||= 0;
          $offset  ||= 0;
          my $level   = 1 + $offset;
  
          local $Carp::CarpLevel = $level;
  
          carp $err if $verbose;
  
          $_ERROR_STRING .= $err . "\n";
      }
  
      sub _clear_error {
          $_ERROR_STRING = '';
      }
  
      sub last_error { $_ERROR_STRING }
  }
  
  1;
  
  =head1 Global Variables
  
  The behaviour of Params::Check can be altered by changing the
  following global variables:
  
  =head2 $Params::Check::VERBOSE
  
  This controls whether Params::Check will issue warnings and
  explanations as to why certain things may have failed.
  If you set it to 0, Params::Check will not output any warnings.
  
  The default is 1 when L<warnings> are enabled, 0 otherwise;
  
  =head2 $Params::Check::STRICT_TYPE
  
  This works like the C<strict_type> option you can pass to C<check>,
  which will turn on C<strict_type> globally for all calls to C<check>.
  
  The default is 0;
  
  =head2 $Params::Check::ALLOW_UNKNOWN
  
  If you set this flag, unknown options will still be present in the
  return value, rather than filtered out. This is useful if your
  subroutine is only interested in a few arguments, and wants to pass
  the rest on blindly to perhaps another subroutine.
  
  The default is 0;
  
  =head2 $Params::Check::STRIP_LEADING_DASHES
  
  If you set this flag, all keys passed in the following manner:
  
      function( -key => 'val' );
  
  will have their leading dashes stripped.
  
  =head2 $Params::Check::NO_DUPLICATES
  
  If set to true, all keys in the template that are marked as to be
  stored in a scalar, will also be removed from the result set.
  
  Default is false, meaning that when you use C<store> as a template
  key, C<check> will put it both in the scalar you supplied, as well as
  in the hashref it returns.
  
  =head2 $Params::Check::PRESERVE_CASE
  
  If set to true, L<Params::Check> will no longer convert all keys from
  the user input to lowercase, but instead expect them to be in the
  case the template provided. This is useful when you want to use
  similar keys with different casing in your templates.
  
  Understand that this removes the case-insensitivity feature of this
  module.
  
  Default is 0;
  
  =head2 $Params::Check::ONLY_ALLOW_DEFINED
  
  If set to true, L<Params::Check> will require all values passed to be
  C<defined>. If you wish to enable this on a 'per key' basis, use the
  template option C<defined> instead.
  
  Default is 0;
  
  =head2 $Params::Check::SANITY_CHECK_TEMPLATE
  
  If set to true, L<Params::Check> will sanity check templates, validating
  for errors and unknown keys. Although very useful for debugging, this
  can be somewhat slow in hot-code and large loops.
  
  To disable this check, set this variable to C<false>.
  
  Default is 1;
  
  =head2 $Params::Check::WARNINGS_FATAL
  
  If set to true, L<Params::Check> will C<croak> when an error during
  template validation occurs, rather than return C<false>.
  
  Default is 0;
  
  =head2 $Params::Check::CALLER_DEPTH
  
  This global modifies the argument given to C<caller()> by
  C<Params::Check::check()> and is useful if you have a custom wrapper
  function around C<Params::Check::check()>. The value must be an
  integer, indicating the number of wrapper functions inserted between
  the real function call and C<Params::Check::check()>.
  
  Example wrapper function, using a custom stacktrace:
  
      sub check {
          my ($template, $args_in) = @_;
  
          local $Params::Check::WARNINGS_FATAL = 1;
          local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
          my $args_out = Params::Check::check($template, $args_in);
  
          my_stacktrace(Params::Check::last_error) unless $args_out;
  
          return $args_out;
      }
  
  Default is 0;
  
  =head1 Acknowledgements
  
  Thanks to Richard Soderberg for his performance improvements.
  
  =head1 BUG REPORTS
  
  Please report bugs or other issues to E<lt>bug-params-check@rt.cpan.orgE<gt>.
  
  =head1 AUTHOR
  
  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
  
  =head1 COPYRIGHT
  
  This library is free software; you may redistribute and/or modify it
  under the same terms as Perl itself.
  
  
  =cut
  
  # Local variables:
  # c-indentation-style: bsd
  # c-basic-offset: 4
  # indent-tabs-mode: nil
  # End:
  # vim: expandtab shiftwidth=4:
PARAMS_CHECK

$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META';
  use 5.008001;
  use strict;
  use warnings;
  package Parse::CPAN::Meta;
  # ABSTRACT: Parse META.yml and META.json CPAN metadata files
  
  our $VERSION = '2.150010';
  
  use Exporter;
  use Carp 'croak';
  
  our @ISA = qw/Exporter/;
  our @EXPORT_OK = qw/Load LoadFile/;
  
  sub load_file {
    my ($class, $filename) = @_;
  
    my $meta = _slurp($filename);
  
    if ($filename =~ /\.ya?ml$/) {
      return $class->load_yaml_string($meta);
    }
    elsif ($filename =~ /\.json$/) {
      return $class->load_json_string($meta);
    }
    else {
      $class->load_string($meta); # try to detect yaml/json
    }
  }
  
  sub load_string {
    my ($class, $string) = @_;
    if ( $string =~ /^---/ ) { # looks like YAML
      return $class->load_yaml_string($string);
    }
    elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
      return $class->load_json_string($string);
    }
    else { # maybe doc-marker-free YAML
      return $class->load_yaml_string($string);
    }
  }
  
  sub load_yaml_string {
    my ($class, $string) = @_;
    my $backend = $class->yaml_backend();
    my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
    croak $@ if $@;
    return $data || {}; # in case document was valid but empty
  }
  
  sub load_json_string {
    my ($class, $string) = @_;
    require Encode;
    # load_json_string takes characters, decode_json expects bytes
    my $encoded = Encode::encode('UTF-8', $string, Encode::PERLQQ());
    my $data = eval { $class->json_decoder()->can('decode_json')->($encoded) };
    croak $@ if $@;
    return $data || {};
  }
  
  sub yaml_backend {
    if ($ENV{PERL_CORE} or not defined $ENV{PERL_YAML_BACKEND} ) {
      _can_load( 'CPAN::Meta::YAML', 0.011 )
        or croak "CPAN::Meta::YAML 0.011 is not available\n";
      return "CPAN::Meta::YAML";
    }
    else {
      my $backend = $ENV{PERL_YAML_BACKEND};
      _can_load( $backend )
        or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
      $backend->can("Load")
        or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
      return $backend;
    }
  }
  
  sub json_decoder {
    if ($ENV{PERL_CORE}) {
      _can_load( 'JSON::PP' => 2.27300 )
        or croak "JSON::PP 2.27300 is not available\n";
      return 'JSON::PP';
    }
    if (my $decoder = $ENV{CPAN_META_JSON_DECODER}) {
      _can_load( $decoder )
        or croak "Could not load CPAN_META_JSON_DECODER '$decoder'\n";
      $decoder->can('decode_json')
        or croak "No decode_json sub provided by CPAN_META_JSON_DECODER '$decoder'\n";
      return $decoder;
    }
    return $_[0]->json_backend;
  }
  
  sub json_backend {
    if ($ENV{PERL_CORE}) {
      _can_load( 'JSON::PP' => 2.27300 )
        or croak "JSON::PP 2.27300 is not available\n";
      return 'JSON::PP';
    }
    if (my $backend = $ENV{CPAN_META_JSON_BACKEND}) {
      _can_load( $backend )
        or croak "Could not load CPAN_META_JSON_BACKEND '$backend'\n";
      $backend->can('new')
        or croak "No constructor provided by CPAN_META_JSON_BACKEND '$backend'\n";
      return $backend;
    }
    if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
      _can_load( 'JSON::PP' => 2.27300 )
        or croak "JSON::PP 2.27300 is not available\n";
      return 'JSON::PP';
    }
    else {
      _can_load( 'JSON' => 2.5 )
        or croak  "JSON 2.5 is required for " .
                  "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
      return "JSON";
    }
  }
  
  sub _slurp {
    require Encode;
    open my $fh, "<:raw", "$_[0]" ## no critic
      or die "can't open $_[0] for reading: $!";
    my $content = do { local $/; <$fh> };
    $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
    return $content;
  }
  
  sub _can_load {
    my ($module, $version) = @_;
    (my $file = $module) =~ s{::}{/}g;
    $file .= ".pm";
    return 1 if $INC{$file};
    return 0 if exists $INC{$file}; # prior load failed
    eval { require $file; 1 }
      or return 0;
    if ( defined $version ) {
      eval { $module->VERSION($version); 1 }
        or return 0;
    }
    return 1;
  }
  
  # Kept for backwards compatibility only
  # Create an object from a file
  sub LoadFile ($) { ## no critic
    return Load(_slurp(shift));
  }
  
  # Parse a document from a string.
  sub Load ($) { ## no critic
    require CPAN::Meta::YAML;
    my $object = eval { CPAN::Meta::YAML::Load(shift) };
    croak $@ if $@;
    return $object;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
  
  =head1 VERSION
  
  version 2.150010
  
  =head1 SYNOPSIS
  
      #############################################
      # In your file
  
      ---
      name: My-Distribution
      version: 1.23
      resources:
        homepage: "http://example.com/dist/My-Distribution"
  
  
      #############################################
      # In your program
  
      use Parse::CPAN::Meta;
  
      my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
  
      # Reading properties
      my $name     = $distmeta->{name};
      my $version  = $distmeta->{version};
      my $homepage = $distmeta->{resources}{homepage};
  
  =head1 DESCRIPTION
  
  B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
  L<JSON::PP> and/or L<CPAN::Meta::YAML>.
  
  B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
  and C<load_yaml_string>.  These will read and deserialize CPAN metafiles, and
  are described below in detail.
  
  B<Parse::CPAN::Meta> provides a legacy API of only two functions,
  based on the YAML functions of the same name. Wherever possible,
  identical calling semantics are used.  These may only be used with YAML sources.
  
  All error reporting is done with exceptions (die'ing).
  
  Note that META files are expected to be in UTF-8 encoding, only.  When
  converted string data, it must first be decoded from UTF-8.
  
  =begin Pod::Coverage
  
  
  
  
  =end Pod::Coverage
  
  =head1 METHODS
  
  =head2 load_file
  
    my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
  
    my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
  
  This method will read the named file and deserialize it to a data structure,
  determining whether it should be JSON or YAML based on the filename.
  The file will be read using the ":utf8" IO layer.
  
  =head2 load_yaml_string
  
    my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
  
  This method deserializes the given string of YAML and returns the first
  document in it.  (CPAN metadata files should always have only one document.)
  If the source was UTF-8 encoded, the string must be decoded before calling
  C<load_yaml_string>.
  
  =head2 load_json_string
  
    my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
  
  This method deserializes the given string of JSON and the result.
  If the source was UTF-8 encoded, the string must be decoded before calling
  C<load_json_string>.
  
  =head2 load_string
  
    my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);
  
  If you don't know whether a string contains YAML or JSON data, this method
  will use some heuristics and guess.  If it can't tell, it assumes YAML.
  
  =head2 yaml_backend
  
    my $backend = Parse::CPAN::Meta->yaml_backend;
  
  Returns the module name of the YAML serializer. See L</ENVIRONMENT>
  for details.
  
  =head2 json_backend
  
    my $backend = Parse::CPAN::Meta->json_backend;
  
  Returns the module name of the JSON serializer.  If C<CPAN_META_JSON_BACKEND>
  is set, this will be whatever that's set to.  If not, this will either
  be L<JSON::PP> or L<JSON>.  If C<PERL_JSON_BACKEND> is set,
  this will return L<JSON> as further delegation is handled by
  the L<JSON> module.  See L</ENVIRONMENT> for details.
  
  =head2 json_decoder
  
    my $decoder = Parse::CPAN::Meta->json_decoder;
  
  Returns the module name of the JSON decoder.  Unlike L</json_backend>, this
  is not necessarily a full L<JSON>-style module, but only something that will
  provide a C<decode_json> subroutine.  If C<CPAN_META_JSON_DECODER> is set,
  this will be whatever that's set to.  If not, this will be whatever has
  been selected as L</json_backend>.  See L</ENVIRONMENT> for more notes.
  
  =head1 FUNCTIONS
  
  For maintenance clarity, no functions are exported by default.  These functions
  are available for backwards compatibility only and are best avoided in favor of
  C<load_file>.
  
  =head2 Load
  
    my @yaml = Parse::CPAN::Meta::Load( $string );
  
  Parses a string containing a valid YAML stream into a list of Perl data
  structures.
  
  =head2 LoadFile
  
    my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
  
  Reads the YAML stream from a file instead of a string.
  
  =head1 ENVIRONMENT
  
  =head2 CPAN_META_JSON_DECODER
  
  By default, L<JSON::PP> will be used for deserializing JSON data.  If the
  C<CPAN_META_JSON_DECODER> environment variable exists, this is expected to
  be the name of a loadable module that provides a C<decode_json> subroutine,
  which will then be used for deserialization.  Relying only on the existence
  of said subroutine allows for maximum compatibility, since this API is
  provided by all of L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS>,
  L<JSON::MaybeXS>, L<JSON::Tiny>, and L<Mojo::JSON>.
  
  =head2 CPAN_META_JSON_BACKEND
  
  By default, L<JSON::PP> will be used for deserializing JSON data.  If the
  C<CPAN_META_JSON_BACKEND> environment variable exists, this is expected to
  be the name of a loadable module that provides the L<JSON> API, since
  downstream code expects to be able to call C<new> on this class.  As such,
  while L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS> and L<JSON::MaybeXS> will
  work for this, to use L<Mojo::JSON> or L<JSON::Tiny> for decoding requires
  setting L</CPAN_META_JSON_DECODER>.
  
  =head2 PERL_JSON_BACKEND
  
  If the C<CPAN_META_JSON_BACKEND> environment variable does not exist, and if
  C<PERL_JSON_BACKEND> environment variable exists, is true and is not
  "JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
  used to interpret C<PERL_JSON_BACKEND>.  If L<JSON> is not installed or is too
  old, an exception will be thrown.  Note that at the time of writing, the only
  useful values are 1, which will tell L<JSON> to guess, or L<JSON::XS> - if
  you want to use a newer JSON module, see L</CPAN_META_JSON_BACKEND>.
  
  =head2 PERL_YAML_BACKEND
  
  By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
  the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
  as a module to use for deserialization.  The given module must be installed,
  must load correctly and must implement the C<Load()> function or an exception
  will be thrown.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Adam Kennedy <adamk@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
  
  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
PARSE_CPAN_META

$fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE';
  package Parse::PMFile;
  
  sub __clean_eval { eval $_[0] } # needs to be here (RT#101273)
  
  use strict;
  use warnings;
  use Safe;
  use JSON::PP ();
  use Dumpvalue;
  use version ();
  use File::Spec ();
  
  our $VERSION = '0.41';
  our $VERBOSE = 0;
  our $ALLOW_DEV_VERSION = 0;
  our $FORK = 0;
  our $UNSAFE = $] < 5.010000 ? 1 : 0;
  
  sub new {
      my ($class, $meta, $opts) = @_;
      bless {%{ $opts || {} }, META_CONTENT => $meta}, $class;
  }
  
  # from PAUSE::pmfile::examine_fio
  sub parse {
      my ($self, $pmfile) = @_;
  
      $pmfile =~ s|\\|/|g;
  
      my($filemtime) = (stat $pmfile)[9];
      $self->{MTIME} = $filemtime;
      $self->{PMFILE} = $pmfile;
  
      unless ($self->_version_from_meta_ok) {
          my $version;
          unless (eval { $version = $self->_parse_version; 1 }) {
            $self->_verbose(1, "error with version in $pmfile: $@");
            return;
          }
  
          $self->{VERSION} = $version;
          if ($self->{VERSION} =~ /^\{.*\}$/) {
              # JSON error message
          } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){   # ignore developer releases and "You suck!"
              return;
          }
      }
  
      my($ppp) = $self->_packages_per_pmfile;
      my @keys_ppp = $self->_filter_ppps(sort keys %$ppp);
      $self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");
  
      #
      # Immediately after each package (pmfile) examined contact
      # the database
      #
  
      my ($package, %errors);
      my %checked_in;
    DBPACK: foreach $package (@keys_ppp) {
          # this part is taken from PAUSE::package::examine_pkg
          # and PAUSE::package::_pkg_name_insane
          if ($package !~ /^\w[\w\:\']*\w?\z/
           || $package !~ /\w\z/
           || $package =~ /:/ && $package !~ /::/
           || $package =~ /\w:\w/
           || $package =~ /:::/
          ){
              $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
              delete $ppp->{$package};
              next;
          }
  
          if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) {
              delete $ppp->{$package};
              next;
          }
  
          # Check that package name matches case of file name
          {
            my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2;
            if ($module) {
              $module =~ s{\.pm\z}{};
              $module =~ s{/}{::}g;
  
              if (lc $module eq lc $package && $module ne $package) {
                # warn "/// $self->{PMFILE} vs. $module vs. $package\n";
                $errors{$package} = {
                  indexing_warning => "Capitalization of package ($package) does not match filename!",
                  infile => $self->{PMFILE},
                };
              }
            }
          }
  
          my $pp = $ppp->{$package};
          if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
              my $err = JSON::PP::decode_json($pp->{version});
              if ($err->{x_normalize}) {
                  $errors{$package} = {
                      normalize => $err->{version},
                      infile => $pp->{infile},
                  };
                  $pp->{version} = "undef";
              } elsif ($err->{openerr}) {
                  $pp->{version} = "undef";
                  $self->_verbose(1,
                                qq{Parse::PMFile was not able to
          read the file. It issued the following error: C< $err->{r} >},
                                );
                  $errors{$package} = {
                      open => $err->{r},
                      infile => $pp->{infile},
                  };
              } else {
                  $pp->{version} = "undef";
                  $self->_verbose(1, 
                                qq{Parse::PMFile was not able to
          parse the following line in that file: C< $err->{line} >
  
          Note: the indexer is running in a Safe compartement and cannot
          provide the full functionality of perl in the VERSION line. It
          is trying hard, but sometime it fails. As a workaround, please
          consider writing a META.yml that contains a 'provides'
          attribute or contact the CPAN admins to investigate (yet
          another) workaround against "Safe" limitations.)},
  
                                );
                  $errors{$package} = {
                      parse_version => $err->{line},
                      infile => $err->{file},
                  };
              }
          }
  
          # Sanity checks
  
          for (
              $package,
              $pp->{version},
          ) {
              if (!defined || /^\s*$/ || /\s/){  # for whatever reason I come here
                  delete $ppp->{$package};
                  next;            # don't screw up 02packages
              }
          }
          unless ($self->_version_ok($pp)) {
              $errors{$package} = {
                  long_version => qq{Version string exceeds maximum allowed length of 16b: "$pp->{version}"},
                  infile => $pp->{infile},
              };
              next;
          }
          $checked_in{$package} = $ppp->{$package};
      }                       # end foreach package
  
      return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in;
  }
  
  sub _version_ok {
      my ($self, $pp) = @_;
      return if length($pp->{version} || 0) > 16;
      return 1
  }
  
  sub _perm_check {
      my ($self, $package) = @_;
      my $userid = $self->{USERID};
      my $module = $self->{PERMISSIONS}->module_permissions($package);
      return 1 if !$module; # not listed yet
      return 1 if defined $module->m && $module->m eq $userid;
      return 1 if defined $module->f && $module->f eq $userid;
      return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c};
      return;
  }
  
  # from PAUSE::pmfile;
  sub _parse_version {
      my $self = shift;
  
      use strict;
  
      my $pmfile = $self->{PMFILE};
      my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));
  
      my $pmcp = $pmfile;
      for ($pmcp) {
          s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
          # solution to escape @s and \
      }
      my($v);
      {
  
          package main; # seems necessary
  
          # XXX: do we need to fork as PAUSE does?
          # or, is alarm() just fine?
          my $pid;
          if ($self->{FORK} || $FORK) {
              $pid = fork();
              die "Can't fork: $!" unless defined $pid;
          }
          if ($pid) {
              waitpid($pid, 0);
              if (open my $fh, '<', $tmpfile) {
                  $v = <$fh>;
              }
          } else {
              # XXX Limit Resources too
  
              my($comp) = Safe->new;
              my $eval = qq{
                  local(\$^W) = 0;
                  Parse::PMFile::_parse_version_safely("$pmcp");
              };
              $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
              $comp->share("*Parse::PMFile::_parse_version_safely");
              $comp->share("*version::new");
              $comp->share("*version::numify");
              $comp->share_from('main', ['*version::',
                                          '*charstar::',
                                          '*Exporter::',
                                          '*DynaLoader::']);
              $comp->share_from('version', ['&qv']);
              $comp->permit(":base_math"); # atan2 (Acme-Pi)
              # $comp->permit("require"); # no strict!
              $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample
  
              version->import('qv') if $self->{UNSAFE} || $UNSAFE;
              {
                  no strict;
                  $v = ($self->{UNSAFE} || $UNSAFE) ? eval $eval : $comp->reval($eval);
              }
              if ($@){ # still in the child process, out of Safe::reval
                  my $err = $@;
                  # warn ">>>>>>>err[$err]<<<<<<<<";
                  if (ref $err) {
                      if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
                          local($^W) = 0;
                          my ($sigil, $vstr) = ($1, $3);
                          $self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/;
                          $v = ($self->{UNSAFE} || $UNSAFE) ? eval $vstr : $comp->reval($vstr);
                          $v = $$v if $sigil eq '*' && ref $v;
                      }
                      if ($@ or !$v) {
                          $self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]",
                                        JSON::PP::encode_json($err),
                                        $eval,
                                      ));
                          $v = JSON::PP::encode_json($err);
                      }
                  } else {
                      $v = JSON::PP::encode_json({ openerr => $err });
                  }
              }
              if (defined $v) {
                  no warnings;
                  $v = $v->numify if ref($v) =~ /^version(::vpp)?$/;
              } else {
                  $v = "";
              }
              if ($self->{FORK} || $FORK) {
                  open my $fh, '>:utf8', $tmpfile;
                  print $fh $v;
                  exit 0;
              } else {
                  utf8::encode($v);
                  # undefine empty $v as if read from the tmpfile
                  $v = undef if defined $v && !length $v;
                  $comp->erase;
                  $self->_restore_overloaded_stuff;
              }
          }
      }
      unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile;
  
      return $self->_normalize_version($v);
  }
  
  sub _restore_overloaded_stuff {
      my ($self, $used_version_in_safe) = @_;
      return if $self->{UNSAFE} || $UNSAFE;
  
      no strict 'refs';
      no warnings 'redefine';
  
      # version XS in CPAN
      my $restored;
      if ($INC{'version/vxs.pm'}) {
          *{'version::(""'} = \&version::vxs::stringify;
          *{'version::(0+'} = \&version::vxs::numify;
          *{'version::(cmp'} = \&version::vxs::VCMP;
          *{'version::(<=>'} = \&version::vxs::VCMP;
          *{'version::(bool'} = \&version::vxs::boolean;
          $restored = 1;
      }
      # version PP in CPAN
      if ($INC{'version/vpp.pm'}) {
          {
              package # hide from PAUSE
                  charstar;
              overload->import;
          }
          if (!$used_version_in_safe) {
              package # hide from PAUSE
                  version::vpp;
              overload->import;
          }
          unless ($restored) {
              *{'version::(""'} = \&version::vpp::stringify;
              *{'version::(0+'} = \&version::vpp::numify;
              *{'version::(cmp'} = \&version::vpp::vcmp;
              *{'version::(<=>'} = \&version::vpp::vcmp;
              *{'version::(bool'} = \&version::vpp::vbool;
          }
          *{'version::vpp::(""'} = \&version::vpp::stringify;
          *{'version::vpp::(0+'} = \&version::vpp::numify;
          *{'version::vpp::(cmp'} = \&version::vpp::vcmp;
          *{'version::vpp::(<=>'} = \&version::vpp::vcmp;
          *{'version::vpp::(bool'} = \&version::vpp::vbool;
          *{'charstar::(""'} = \&charstar::thischar;
          *{'charstar::(0+'} = \&charstar::thischar;
          *{'charstar::(++'} = \&charstar::increment;
          *{'charstar::(--'} = \&charstar::decrement;
          *{'charstar::(+'} = \&charstar::plus;
          *{'charstar::(-'} = \&charstar::minus;
          *{'charstar::(*'} = \&charstar::multiply;
          *{'charstar::(cmp'} = \&charstar::cmp;
          *{'charstar::(<=>'} = \&charstar::spaceship;
          *{'charstar::(bool'} = \&charstar::thischar;
          *{'charstar::(='} = \&charstar::clone;
          $restored = 1;
      }
      # version in core
      if (!$restored) {
          *{'version::(""'} = \&version::stringify;
          *{'version::(0+'} = \&version::numify;
          *{'version::(cmp'} = \&version::vcmp;
          *{'version::(<=>'} = \&version::vcmp;
          *{'version::(bool'} = \&version::boolean;
      }
  }
  
  # from PAUSE::pmfile;
  sub _packages_per_pmfile {
      my $self = shift;
  
      my $ppp = {};
      my $pmfile = $self->{PMFILE};
      my $filemtime = $self->{MTIME};
      my $version = $self->{VERSION};
  
      open my $fh, "<", "$pmfile" or return $ppp;
  
      local $/ = "\n";
      my $inpod = 0;
  
    PLINE: while (<$fh>) {
          chomp;
          my($pline) = $_;
          $inpod = $pline =~ /^=(?!cut)/ ? 1 :
              $pline =~ /^=cut/ ? 0 : $inpod;
          next if $inpod;
          next if substr($pline,0,4) eq "=cut";
  
          $pline =~ s/\#.*//;
          next if $pline =~ /^\s*$/;
          if ($pline =~ /^__(?:END|DATA)__\b/
              and $pmfile !~ /\.PL$/   # PL files may well have code after __DATA__
              ){
              last PLINE;
          }
  
          my $pkg;
          my $strict_version;
  
          if (
              $pline =~ m{
                        # (.*) # takes too much time if $pline is long
                        #(?<![*\$\\@%&]) # no sigils
                        ^[\s\{;]*
                        \bpackage\s+
                        ([\w\:\']+)
                        \s*
                        (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
                      }x) {
              $pkg = $1;
              $strict_version = $2;
              if ($pkg eq "DB"){
                  # XXX if pumpkin and perl make him comaintainer! I
                  # think I always made the pumpkins comaint on DB
                  # without further ado (?)
                  next PLINE;
              }
          }
  
          if ($pkg) {
              # Found something
  
              # from package
              $pkg =~ s/\'/::/g;
              next PLINE unless $pkg =~ /^[A-Za-z]/;
              next PLINE unless $pkg =~ /\w$/;
              next PLINE if $pkg eq "main";
              # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
              # database for modid in mods, package in packages, package in perms
              # alter table mods modify modid varchar(128) binary NOT NULL default '';
              # alter table packages modify package varchar(128) binary NOT NULL default '';
              next PLINE if length($pkg) > 128;
              #restriction
              $ppp->{$pkg}{parsed}++;
              $ppp->{$pkg}{infile} = $pmfile;
              if ($self->_simile($pmfile,$pkg)) {
                  $ppp->{$pkg}{simile} = $pmfile;
                  if ($self->_version_from_meta_ok) {
                      my $provides = $self->{META_CONTENT}{provides};
                      if (exists $provides->{$pkg}) {
                          if (defined $provides->{$pkg}{version}) {
                              my $v = $provides->{$pkg}{version};
                              if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){   # ignore developer releases and "You suck!"
                                  next PLINE;
                              }
  
                              unless (eval { $version = $self->_normalize_version($v); 1 }) {
                                $self->_verbose(1, "error with version in $pmfile: $@");
                                next;
  
                              }
                              $ppp->{$pkg}{version} = $version;
                          } else {
                              $ppp->{$pkg}{version} = "undef";
                          }
                      }
                  } else {
                      if (defined $strict_version){
                          $ppp->{$pkg}{version} = $strict_version ;
                      } else {
                          $ppp->{$pkg}{version} = defined $version ? $version : "";
                      }
                      no warnings;
                      if ($version eq 'undef') {
                          $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
                      } else {
                          $ppp->{$pkg}{version} =
                              $version
                                  if $version
                                      > $ppp->{$pkg}{version} ||
                                          $version
                                              gt $ppp->{$pkg}{version};
                      }
                  }
              } else {        # not simile
                  #### it comes later, it would be nonsense
                  #### to set to "undef". MM_Unix gives us
                  #### the best we can reasonably consider
                  $ppp->{$pkg}{version} =
                      $version
                          unless defined $ppp->{$pkg}{version} &&
                              length($ppp->{$pkg}{version});
              }
              $ppp->{$pkg}{filemtime} = $filemtime;
          } else {
              # $self->_verbose(2,"no pkg found");
          }
      }
  
      close $fh;
      $ppp;
  }
  
  # from PAUSE::pmfile;
  {
      no strict;
      sub _parse_version_safely {
          my($parsefile) = @_;
          my $result;
          local *FH;
          local $/ = "\n";
          open(FH,$parsefile) or die "Could not open '$parsefile': $!";
          my $inpod = 0;
          while (<FH>) {
              $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
              next if $inpod || /^\s*#/;
              last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer
              chop;
  
              if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) {
                # XXX: should handle this better if version is bogus -- rjbs,
                # 2014-03-16
                return $ver if version::is_lax($ver);
              }
  
              # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
              next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;
              my $current_parsed_line = $_;
              my $eval = qq{
                  package #
                      ExtUtils::MakeMaker::_version;
  
                  local $1$2;
                  \$$2=undef; do {
                      $_
                  }; \$$2
              };
              local $^W = 0;
              local $SIG{__WARN__} = sub {};
              $result = __clean_eval($eval);
              # warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
              if ($@ or !defined $result){
                  die +{
                        eval => $eval,
                        line => $current_parsed_line,
                        file => $parsefile,
                        err => $@,
                        };
              }
              last;
          } #;
          close FH;
  
          $result = "undef" unless defined $result;
          if ((ref $result) =~ /^version(?:::vpp)?\b/) {
              no warnings;
              $result = $result->numify;
          }
          return $result;
      }
  }
  
  # from PAUSE::pmfile;
  sub _filter_ppps {
      my($self,@ppps) = @_;
      my @res;
  
      # very similar code is in PAUSE::dist::filter_pms
    MANI: for my $ppp ( @ppps ) {
          if ($self->{META_CONTENT}){
              my $no_index = $self->{META_CONTENT}{no_index}
                              || $self->{META_CONTENT}{private}; # backward compat
              if (ref($no_index) eq 'HASH') {
                  my %map = (
                              package => qr{\z},
                              namespace => qr{::},
                            );
                  for my $k (qw(package namespace)) {
                      next unless my $v = $no_index->{$k};
                      my $rest = $map{$k};
                      if (ref $v eq "ARRAY") {
                          for my $ve (@$v) {
                              $ve =~ s|::$||;
                              if ($ppp =~ /^$ve$rest/){
                                  $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
                                  next MANI;
                              } else {
                                  $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
                              }
                          }
                      } else {
                          $v =~ s|::$||;
                          if ($ppp =~ /^$v$rest/){
                              $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
                              next MANI;
                          } else {
                              $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
                          }
                      }
                  }
              } else {
                  $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
              }
          } else {
              # $self->_verbose(1,"no META_CONTENT"); # too noisy
          }
          push @res, $ppp;
      }
      $self->_verbose(1,"Result of filter_ppps: res[@res]");
      @res;
  }
  
  # from PAUSE::pmfile;
  sub _simile {
      my($self,$file,$package) = @_;
      # MakeMaker gives them the chance to have the file Simple.pm in
      # this directory but have the package HTML::Simple in it.
      # Afaik, they wouldn't be able to do so with deeper nested packages
      $file =~ s|.*/||;
      $file =~ s|\.pm(?:\.PL)?||;
      my $ret = $package =~ m/\b\Q$file\E$/;
      $ret ||= 0;
      unless ($ret) {
          # Apache::mod_perl_guide stuffs it into Version.pm
          $ret = 1 if lc $file eq 'version';
      }
      $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
      $ret;
  }
  
  # from PAUSE::pmfile
  sub _normalize_version {
      my($self,$v) = @_;
      $v = "undef" unless defined $v;
      my $dv = Dumpvalue->new;
      my $sdv = $dv->stringify($v,1); # second argument prevents ticks
      $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");
  
      return $v if $v eq "undef";
      return $v if $v =~ /^\{.*\}$/; # JSON object
      $v =~ s/^\s+//;
      $v =~ s/\s+\z//;
      if ($v =~ /_/) {
          # XXX should pass something like EDEVELOPERRELEASE up e.g.
          # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
          # such modules and the mesage was not helpful that "nothing
          # was found".
          return $v ;
      }
      if (!version::is_lax($v)) {
          return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v });
      }
      # may warn "Integer overflow"
      my $vv = eval { no warnings; version->new($v)->numify };
      if ($@) {
          # warn "$v: $@";
          return JSON::PP::encode_json({ x_normalize => $@, version => $v });
          # return "undef";
      }
      if ($vv eq $v) {
          # the boring 3.14
      } else {
          my $forced = $self->_force_numeric($v);
          if ($forced eq $vv) {
          } elsif ($forced =~ /^v(.+)/) {
              # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
              no warnings;
              $vv = version->new($1)->numify;
          } else {
              # warn "Unequal forced[$forced] and vv[$vv]";
              if ($forced == $vv) {
                  # the trailing zeroes would cause unnecessary havoc
                  $vv = $forced;
              }
          }
      }
      return $vv;
  }
  
  # from PAUSE::pmfile;
  sub _force_numeric {
      my($self,$v) = @_;
      $v = $self->_readable($v);
  
      if (
          $v =~
          /^(\+?)(\d*)(\.(\d*))?/ &&
          # "$2$4" ne ''
          (
            defined $2 && length $2
            ||
            defined $4 && length $4
          )
          ) {
          my $two = defined $2 ? $2 : "";
          my $three = defined $3 ? $3 : "";
          $v = "$two$three";
      }
      # no else branch! We simply say, everything else is a string.
      $v;
  }
  
  # from PAUSE::dist
  sub _version_from_meta_ok {
    my($self) = @_;
    return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
    my $c = $self->{META_CONTENT};
  
    # If there's no provides hash, we can't get our module versions from the
    # provides hash! -- rjbs, 2012-03-31
    return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};
  
    # Some versions of Module::Build geneated an empty provides hash.  If we're
    # *not* looking at a Module::Build-generated metafile, then it's okay.
    my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
    return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;
  
    # ??? I don't know why this is here.
    return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';
  
    if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
        # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
        # did not find the reason why this happened, but let's not go
        # overboard, 0.26 seems a good threshold from the statistics: there
        # are not many empty provides hashes from 0.26 up.
        return($self->{VERSION_FROM_META_OK} = 0);
    }
  
    # We're not in the suspect range of M::B versions.  It's good to go.
    return($self->{VERSION_FROM_META_OK} = 1);
  }
  
  sub _verbose {
      my($self,$level,@what) = @_;
      warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE);
  }
  
  # all of the following methods are stripped from CPAN::Version
  # (as of version 5.5001, bundled in CPAN 2.03), and slightly
  # modified (ie. made private, as well as CPAN->debug(...) are
  # replaced with $self->_verbose(9, ...).)
  
  # CPAN::Version::vcmp courtesy Jost Krieger
  sub _vcmp {
      my($self,$l,$r) = @_;
      local($^W) = 0;
      $self->_verbose(9, "l[$l] r[$r]");
  
      return 0 if $l eq $r; # short circuit for quicker success
  
      for ($l,$r) {
          s/_//g;
      }
      $self->_verbose(9, "l[$l] r[$r]");
      for ($l,$r) {
          next unless tr/.// > 1 || /^v/;
          s/^v?/v/;
          1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
      }
      $self->_verbose(9, "l[$l] r[$r]");
      if ($l=~/^v/ <=> $r=~/^v/) {
          for ($l,$r) {
              next if /^v/;
              $_ = $self->_float2vv($_);
          }
      }
      $self->_verbose(9, "l[$l] r[$r]");
      my $lvstring = "v0";
      my $rvstring = "v0";
      if ($] >= 5.006
       && $l =~ /^v/
       && $r =~ /^v/) {
          $lvstring = $self->_vstring($l);
          $rvstring = $self->_vstring($r);
          $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring);
      }
  
      return (
              ($l ne "undef") <=> ($r ne "undef")
              ||
              $lvstring cmp $rvstring
              ||
              $l <=> $r
              ||
              $l cmp $r
      );
  }
  
  sub _vgt {
      my($self,$l,$r) = @_;
      $self->_vcmp($l,$r) > 0;
  }
  
  sub _vlt {
      my($self,$l,$r) = @_;
      $self->_vcmp($l,$r) < 0;
  }
  
  sub _vge {
      my($self,$l,$r) = @_;
      $self->_vcmp($l,$r) >= 0;
  }
  
  sub _vle {
      my($self,$l,$r) = @_;
      $self->_vcmp($l,$r) <= 0;
  }
  
  sub _vstring {
      my($self,$n) = @_;
      $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";
      pack "U*", split /\./, $n;
  }
  
  # vv => visible vstring
  sub _float2vv {
      my($self,$n) = @_;
      my($rev) = int($n);
      $rev ||= 0;
      my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
                                            # architecture influence
      $mantissa ||= 0;
      $mantissa .= "0" while length($mantissa)%3;
      my $ret = "v" . $rev;
      while ($mantissa) {
          $mantissa =~ s/(\d{1,3})// or
              die "Panic: length>0 but not a digit? mantissa[$mantissa]";
          $ret .= ".".int($1);
      }
      # warn "n[$n]ret[$ret]";
      $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
      $ret;
  }
  
  sub _readable {
      my($self,$n) = @_;
      $n =~ /^([\w\-\+\.]+)/;
  
      return $1 if defined $1 && length($1)>0;
      # if the first user reaches version v43, he will be treated as "+".
      # We'll have to decide about a new rule here then, depending on what
      # will be the prevailing versioning behavior then.
  
      if ($] < 5.006) { # or whenever v-strings were introduced
          # we get them wrong anyway, whatever we do, because 5.005 will
          # have already interpreted 0.2.4 to be "0.24". So even if he
          # indexer sends us something like "v0.2.4" we compare wrongly.
  
          # And if they say v1.2, then the old perl takes it as "v12"
  
          $self->_verbose(9, "Suspicious version string seen [$n]\n");
          return $n;
      }
      my $better = sprintf "v%vd", $n;
      $self->_verbose(9, "n[$n] better[$better]");
      return $better;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Parse::PMFile - parses .pm file as PAUSE does
  
  =head1 SYNOPSIS
  
      use Parse::PMFile;
  
      my $parser = Parse::PMFile->new($metadata, {VERBOSE => 1});
      my $packages_info = $parser->parse($pmfile);
  
      # if you need info about invalid versions
      my ($packages_info, $errors) = $parser->parse($pmfile);
  
      # to check permissions
      my $parser = Parse::PMFile->new($metadata, {
          USERID => 'ISHIGAKI',
          PERMISSIONS => PAUSE::Permissions->new,
      });
  
  =head1 DESCRIPTION
  
  The most of the code of this module is taken from the PAUSE code as of April 2013 almost verbatim. Thus, the heart of this module should be quite stable. However, I made it not to use pipe ("-|") as well as I stripped database-related code. If you encounter any issue, that's most probably because of my modification.
  
  This module doesn't provide features to extract a distribution or parse meta files intentionally.
  
  =head1 METHODS
  
  =head2 new
  
  creates an object. You can also pass a hashref taken from META.yml etc, and an optional hashref. Options are:
  
  =over 4
  
  =item ALLOW_DEV_VERSION
  
  Parse::PMFile usually ignores a version with an underscore as PAUSE does (because it's for a developer release, and should not be indexed). Set this option to true if you happen to need to keep such a version for better analysis.
  
  =item VERBOSE
  
  Set this to true if you need to know some details.
  
  =item FORK
  
  As of version 0.17, Parse::PMFile stops forking while parsing a version for better performance. Parse::PMFile should return the same result no matter how this option is set, but if you do care, set this to true to fork as PAUSE does.
  
  =item USERID, PERMISSIONS
  
  As of version 0.21, Parse::PMFile checks permissions of a package if both USERID and PERMISSIONS (which should be an instance of L<PAUSE::Permissions>) are provided. Unauthorized packages are removed.
  
  =item UNSAFE
  
  Parse::PMFile usually parses a module version in a Safe compartment. However, this approach doesn't work smoothly under older perls (prior to 5.10) plus some combinations of recent versions of Safe.pm (2.24 and above) and version.pm (0.9905 and above) for various reasons. As of version 0.27, Parse::PMFile simply uses C<eval> to parse a version under older perls. If you want it to use always C<eval> (even under recent perls), set this to true.
  
  =back
  
  =head2 parse
  
  takes a path to a .pm file, and returns a hash reference that holds information for package(s) found in the file.
  
  =head1 SEE ALSO
  
  L<Parse::LocalDistribution>, L<PAUSE::Permissions>
  
  Most part of this module is derived from PAUSE and CPAN::Version.
  
  L<https://github.com/andk/pause>
  
  L<https://github.com/andk/cpanpm>
  
  =head1 AUTHOR
  
  Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
  
  Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> for most of the code.
  
  Copyright 2013 by Kenichi Ishigaki for some.
  
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
PARSE_PMFILE

$fatpacked{"Search/Dict.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SEARCH_DICT';
  package Search::Dict;
  require 5.000;
  require Exporter;
  
  my $fc_available;
  BEGIN {
    $fc_available = '5.015008';
    if ( $] ge $fc_available ) {
      require feature;
      'feature'->import('fc'); # string avoids warning on old Perls <sigh>
    }
  }
  
  use strict;
  
  our $VERSION = '1.07';
  our @ISA = qw(Exporter);
  our @EXPORT = qw(look);
  
  =head1 NAME
  
  Search::Dict - look - search for key in dictionary file
  
  =head1 SYNOPSIS
  
      use Search::Dict;
      look *FILEHANDLE, $key, $dict, $fold;
  
      use Search::Dict;
      look *FILEHANDLE, $params;
  
  =head1 DESCRIPTION
  
  Sets file position in FILEHANDLE to be first line greater than or equal
  (stringwise) to I<$key>.  Returns the new file position, or -1 if an error
  occurs.
  
  The flags specify dictionary order and case folding:
  
  If I<$dict> is true, search by dictionary order (ignore anything but word
  characters and whitespace).  The default is honour all characters.
  
  If I<$fold> is true, ignore case.  The default is to honour case.
  
  If there are only three arguments and the third argument is a hash
  reference, the keys of that hash can have values C<dict>, C<fold>, and
  C<comp> or C<xfrm> (see below), and their corresponding values will be
  used as the parameters.
  
  If a comparison subroutine (comp) is defined, it must return less than zero,
  zero, or greater than zero, if the first comparand is less than,
  equal, or greater than the second comparand.
  
  If a transformation subroutine (xfrm) is defined, its value is used to
  transform the lines read from the filehandle before their comparison.
  
  =cut
  
  sub look {
      my($fh,$key,$dict,$fold) = @_;
      my ($comp, $xfrm);
      if (@_ == 3 && ref $dict eq 'HASH') {
  	my $params = $dict;
  	$dict = 0;
  	$dict = $params->{dict} if exists $params->{dict};
  	$fold = $params->{fold} if exists $params->{fold};
  	$comp = $params->{comp} if exists $params->{comp};
  	$xfrm = $params->{xfrm} if exists $params->{xfrm};
      }
      $comp = sub { $_[0] cmp $_[1] } unless defined $comp;
      local($_);
      my $fno = fileno $fh;
      my @stat;
      if ( defined $fno && $fno >= 0 && ! tied *{$fh} ) { # real, open file
        @stat = eval { stat($fh) }; # in case fileno lies
      }
      my($size, $blksize) = @stat[7,11];
      $size = do { seek($fh,0,2); my $s = tell($fh); seek($fh,0,0); $s }
          unless defined $size;
      $blksize ||= 8192;
      $key =~ s/[^\w\s]//g if $dict;
      if ( $fold ) {
        $key = $] ge $fc_available ? fc($key) : lc($key);
      }
      # find the right block
      my($min, $max) = (0, int($size / $blksize));
      my $mid;
      while ($max - $min > 1) {
  	$mid = int(($max + $min) / 2);
  	seek($fh, $mid * $blksize, 0)
  	    or return -1;
  	<$fh> if $mid;			# probably a partial line
  	$_ = <$fh>;
  	$_ = $xfrm->($_) if defined $xfrm;
  	chomp;
  	s/[^\w\s]//g if $dict;
          if ( $fold ) {
            $_ = $] ge $fc_available ? fc($_) : lc($_);
          }
  	if (defined($_) && $comp->($_, $key) < 0) {
  	    $min = $mid;
  	}
  	else {
  	    $max = $mid;
  	}
      }
      # find the right line
      $min *= $blksize;
      seek($fh,$min,0)
  	or return -1;
      <$fh> if $min;
      for (;;) {
  	$min = tell($fh);
  	defined($_ = <$fh>)
  	    or last;
  	$_ = $xfrm->($_) if defined $xfrm;
  	chomp;
  	s/[^\w\s]//g if $dict;
          if ( $fold ) {
            $_ = $] ge $fc_available ? fc($_) : lc($_);
          }
  	last if $comp->($_, $key) >= 0;
      }
      seek($fh,$min,0);
      $min;
  }
  
  1;
SEARCH_DICT

$fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE';
  # $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
  #
  # Copyright (c) 1997 Roderick Schertler.  All rights reserved.  This
  # program is free software; you can redistribute it and/or modify it
  # under the same terms as Perl itself.
  
  =head1 NAME
  
  String::ShellQuote - quote strings for passing through the shell
  
  =head1 SYNOPSIS
  
      $string = shell_quote @list;
      $string = shell_quote_best_effort @list;
      $string = shell_comment_quote $string;
  
  =head1 DESCRIPTION
  
  This module contains some functions which are useful for quoting strings
  which are going to pass through the shell or a shell-like object.
  
  =over
  
  =cut
  
  package String::ShellQuote;
  
  use strict;
  use vars qw($VERSION @ISA @EXPORT);
  
  require Exporter;
  
  $VERSION	= '1.04';
  @ISA		= qw(Exporter);
  @EXPORT		= qw(shell_quote shell_quote_best_effort shell_comment_quote);
  
  sub croak {
      require Carp;
      goto &Carp::croak;
  }
  
  sub _shell_quote_backend {
      my @in = @_;
      my @err = ();
  
      if (0) {
  	require RS::Handy;
  	print RS::Handy::data_dump(\@in);
      }
  
      return \@err, '' unless @in;
  
      my $ret = '';
      my $saw_non_equal = 0;
      foreach (@in) {
  	if (!defined $_ or $_ eq '') {
  	    $_ = "''";
  	    next;
  	}
  
  	if (s/\x00//g) {
  	    push @err, "No way to quote string containing null (\\000) bytes";
  	}
  
      	my $escape = 0;
  
  	# = needs quoting when it's the first element (or part of a
  	# series of such elements), as in command position it's a
  	# program-local environment setting
  
  	if (/=/) {
  	    if (!$saw_non_equal) {
  	    	$escape = 1;
  	    }
  	}
  	else {
  	    $saw_non_equal = 1;
  	}
  
  	if (m|[^\w!%+,\-./:=@^]|) {
  	    $escape = 1;
  	}
  
  	if ($escape
  		|| (!$saw_non_equal && /=/)) {
  
  	    # ' -> '\''
      	    s/'/'\\''/g;
  
  	    # make multiple ' in a row look simpler
  	    # '\'''\'''\'' -> '"'''"'
      	    s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
  
  	    $_ = "'$_'";
  	    s/^''//;
  	    s/''$//;
  	}
      }
      continue {
  	$ret .= "$_ ";
      }
  
      chop $ret;
      return \@err, $ret;
  }
  
  =item B<shell_quote> [I<string>]...
  
  B<shell_quote> quotes strings so they can be passed through the shell.
  Each I<string> is quoted so that the shell will pass it along as a
  single argument and without further interpretation.  If no I<string>s
  are given an empty string is returned.
  
  If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
  
  =cut
  
  sub shell_quote {
      my ($rerr, $s) = _shell_quote_backend @_;
  
      if (@$rerr) {
      	my %seen;
      	@$rerr = grep { !$seen{$_}++ } @$rerr;
  	my $s = join '', map { "shell_quote(): $_\n" } @$rerr;
  	chomp $s;
  	croak $s;
      }
      return $s;
  }
  
  =item B<shell_quote_best_effort> [I<string>]...
  
  This is like B<shell_quote>, excpet if the string can't be safely quoted
  it does the best it can and returns the result, instead of dying.
  
  =cut
  
  sub shell_quote_best_effort {
      my ($rerr, $s) = _shell_quote_backend @_;
  
      return $s;
  }
  
  =item B<shell_comment_quote> [I<string>]
  
  B<shell_comment_quote> quotes the I<string> so that it can safely be
  included in a shell-style comment (the current algorithm is that a sharp
  character is placed after any newlines in the string).
  
  This routine might be changed to accept multiple I<string> arguments
  in the future.  I haven't done this yet because I'm not sure if the
  I<string>s should be joined with blanks ($") or nothing ($,).  Cast
  your vote today!  Be sure to justify your answer.
  
  =cut
  
  sub shell_comment_quote {
      return '' unless @_;
      unless (@_ == 1) {
  	croak "Too many arguments to shell_comment_quote "
  	    	    . "(got " . @_ . " expected 1)";
      }
      local $_ = shift;
      s/\n/\n#/g;
      return $_;
  }
  
  1;
  
  __END__
  
  =back
  
  =head1 EXAMPLES
  
      $cmd = 'fuser 2>/dev/null ' . shell_quote @files;
      @pids = split ' ', `$cmd`;
  
      print CFG "# Configured by: ",
  		shell_comment_quote($ENV{LOGNAME}), "\n";
  
  =head1 BUGS
  
  Only Bourne shell quoting is supported.  I'd like to add other shells
  (particularly cmd.exe), but I'm not familiar with them.  It would be a
  big help if somebody supplied the details.
  
  =head1 AUTHOR
  
  Roderick Schertler <F<roderick@argon.org>>
  
  =head1 SEE ALSO
  
  perl(1).
  
  =cut
STRING_SHELLQUOTE

$fatpacked{"Sub/Exporter/Progressive.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_EXPORTER_PROGRESSIVE';
  package Sub::Exporter::Progressive;
  $Sub::Exporter::Progressive::VERSION = '0.001013';
  use strict;
  use warnings;
  
  # ABSTRACT: Only use Sub::Exporter if you need it
  
  sub _croak {
    require Carp;
    &Carp::croak;
  }
  
  sub import {
     my ($self, @args) = @_;
  
     my $inner_target = caller;
     my $export_data = sub_export_options($inner_target, @args);
  
     my $full_exporter;
     no strict 'refs';
     no warnings 'once';
     @{"${inner_target}::EXPORT_OK"} = @{$export_data->{exports}};
     @{"${inner_target}::EXPORT"} = @{$export_data->{defaults}};
     %{"${inner_target}::EXPORT_TAGS"} = %{$export_data->{tags}};
     *{"${inner_target}::import"} = sub {
        use strict;
        my ($self, @args) = @_;
  
        if ( grep {
           length ref $_
              or
           $_ !~ / \A [:-]? \w+ \z /xm
        } @args ) {
           _croak 'your usage of Sub::Exporter::Progressive requires Sub::Exporter to be installed'
              unless eval { require Sub::Exporter };
           $full_exporter ||= Sub::Exporter::build_exporter($export_data->{original});
  
           goto $full_exporter;
        } elsif ( defined( (my ($num) = grep { m/^\d/ } @args)[0] ) ) {
           _croak "cannot export symbols with a leading digit: '$num'";
        } else {
           require Exporter;
           s/ \A - /:/xm for @args;
           @_ = ($self, @args);
           goto \&Exporter::import;
        }
     };
     return;
  }
  
  my $too_complicated = <<'DEATH';
  You are using Sub::Exporter::Progressive, but the features your program uses from
  Sub::Exporter cannot be implemented without Sub::Exporter, so you might as well
  just use vanilla Sub::Exporter
  DEATH
  
  sub sub_export_options {
     my ($inner_target, $setup, $options) = @_;
  
     my @exports;
     my @defaults;
     my %tags;
  
     if ( ($setup||'') eq '-setup') {
        my %options = %$options;
  
        OPTIONS:
        for my $opt (keys %options) {
           if ($opt eq 'exports') {
  
              _croak $too_complicated if ref $options{exports} ne 'ARRAY';
              @exports = @{$options{exports}};
              _croak $too_complicated if grep { length ref $_ } @exports;
  
           } elsif ($opt eq 'groups') {
              %tags = %{$options{groups}};
              for my $tagset (values %tags) {
                 _croak $too_complicated if grep {
                    length ref $_
                       or
                    $_ =~ / \A - (?! all \b ) /x
                 } @{$tagset};
              }
              @defaults = @{$tags{default} || [] };
           } else {
              _croak $too_complicated;
           }
        }
        @{$_} = map { / \A  [:-] all \z /x ? @exports : $_ } @{$_} for \@defaults, values %tags;
        $tags{all} ||= [ @exports ];
        my %exports = map { $_ => 1 } @exports;
        my @errors = grep { not $exports{$_} } @defaults;
        _croak join(', ', @errors) . " is not exported by the $inner_target module\n" if @errors;
     }
  
     return {
        exports => \@exports,
        defaults => \@defaults,
        original => $options,
        tags => \%tags,
     };
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Sub::Exporter::Progressive - Only use Sub::Exporter if you need it
  
  =head1 VERSION
  
  version 0.001013
  
  =head1 SYNOPSIS
  
   package Syntax::Keyword::Gather;
  
   use Sub::Exporter::Progressive -setup => {
     exports => [qw( break gather gathered take )],
     groups => {
       default => [qw( break gather gathered take )],
     },
   };
  
   # elsewhere
  
   # uses Exporter for speed
   use Syntax::Keyword::Gather;
  
   # somewhere else
  
   # uses Sub::Exporter for features
   use Syntax::Keyword::Gather 'gather', take => { -as => 'grab' };
  
  =head1 DESCRIPTION
  
  L<Sub::Exporter> is an incredibly powerful module, but with that power comes
  great responsibility, er- as well as some runtime penalties.  This module
  is a C<Sub::Exporter> wrapper that will let your users just use L<Exporter>
  if all they are doing is picking exports, but use C<Sub::Exporter> if your
  users try to use C<Sub::Exporter>'s more advanced features, like
  renaming exports, if they try to use them.
  
  Note that this module will export C<@EXPORT>, C<@EXPORT_OK> and
  C<%EXPORT_TAGS> package variables for C<Exporter> to work.  Additionally, if
  your package uses advanced C<Sub::Exporter> features like currying, this module
  will only ever use C<Sub::Exporter>, so you might as well use it directly.
  
  =head1 CONTRIBUTORS
  
  ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  leont - Leon Timmermans (cpan:LEONT) <leont@cpan.org>
  
  =head1 AUTHOR
  
  Arthur Axel "fREW" Schmidt <Sub-Exporter-Progressive@afoolishmanifesto.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2016 by Arthur Axel "fREW" Schmidt.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
SUB_EXPORTER_PROGRESSIVE

$fatpacked{"Tie/Handle/Offset.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIE_HANDLE_OFFSET';
  use strict;
  BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } }
  
  package Tie::Handle::Offset;
  # ABSTRACT: Tied handle that hides the beginning of a file
  our $VERSION = '0.003'; # VERSION
  
  use Tie::Handle;
  our @ISA = qw/Tie::Handle/;
  
  #--------------------------------------------------------------------------#
  # Glob slot accessor
  #--------------------------------------------------------------------------#
  
  sub offset {
    my $self = shift;
    if ( @_ ) {
      return ${*$self}{offset} = shift;
    }
    else {
      return ${*$self}{offset};
    }
  }
  
  #--------------------------------------------------------------------------#
  # Tied handle methods
  #--------------------------------------------------------------------------#
  
  sub TIEHANDLE
  {
    my $class = shift;
    my $params;
    $params = pop if ref $_[-1] eq 'HASH';
  
    my $self    = \do { no warnings 'once'; local *HANDLE};
    bless $self,$class;
  
    $self->OPEN(@_) if (@_);
    if ( $params->{offset} ) {
      seek( $self, $self->offset( $params->{offset} ), 0 );
    }
    return $self;
  }
  
  sub TELL    {
    my $cur = tell($_[0]) - $_[0]->offset;
    # XXX shouldn't ever be less than zero, but just in case...
    return $cur > 0 ? $cur : 0;
  }
  
  sub SEEK    {
    my ($self, $pos, $whence) = @_;
    my $rc;
    if ( $whence == 0 || $whence == 1 ) { # pos from start, cur
      $rc = seek($self, $pos + $self->offset, $whence);
    }
    elsif ( _size($self) + $pos < $self->offset ) { # from end
      $rc = '';
    }
    else {
      $rc = seek($self,$pos,$whence);
    }
    return $rc;
  }
  
  sub OPEN
  {
    $_[0]->offset(0);
    $_[0]->CLOSE if defined($_[0]->FILENO);
    @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
  }
  
  sub _size {
    my ($self) = @_;
    my $cur = tell($self);
    seek($self,0,2); # end
    my $size = tell($self);
    seek($self,$cur,0); # reset
    return $size;
  }
  
  #--------------------------------------------------------------------------#
  # Methods copied from Tie::StdHandle to avoid dependency on Perl 5.8.9/5.10.0
  #--------------------------------------------------------------------------#
  
  sub EOF     { eof($_[0]) }
  sub FILENO  { fileno($_[0]) }
  sub CLOSE   { close($_[0]) }
  sub BINMODE { binmode($_[0]) }
  sub READ     { read($_[0],$_[1],$_[2]) }
  sub READLINE { my $fh = $_[0]; <$fh> }
  sub GETC     { getc($_[0]) }
  
  sub WRITE
  {
   my $fh = $_[0];
   print $fh substr($_[1],0,$_[2])
  }
  
  1;
  
  
  # vim: ts=2 sts=2 sw=2 et:
  
  __END__
  =pod
  
  =head1 NAME
  
  Tie::Handle::Offset - Tied handle that hides the beginning of a file
  
  =head1 VERSION
  
  version 0.003
  
  =head1 SYNOPSIS
  
    use Tie::Handle::Offset;
  
    tie *FH, 'Tie::Handle::Offset', "<", $filename, { offset => 20 };
  
  =head1 DESCRIPTION
  
  This modules provides a file handle that hides the beginning of a file.
  After opening, the file is positioned at the offset location. C<seek()> and
  C<tell()> calls are modified to preserve the offset.
  
  For example, C<tell($fh)> will return 0, though the actual file position
  is at the offset.  Likewise, C<seek($fh,80,0)> will seek to 80 bytes from
  the offset instead of 80 bytes from the actual start of the file.
  
  =for Pod::Coverage method_names_here
  
  =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<http://rt.cpan.org/Public/Dist/Display.html?Name=Tie-Handle-Offset>.
  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/tie-handle-offset>
  
    git clone https://github.com/dagolden/tie-handle-offset.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2012 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
  
TIE_HANDLE_OFFSET

$fatpacked{"Tie/Handle/SkipHeader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIE_HANDLE_SKIPHEADER';
  use strict;
  BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } }
  
  package Tie::Handle::SkipHeader;
  # ABSTRACT: Tied handle that hides an RFC822-style header
  our $VERSION = '0.003'; # VERSION
  
  use Tie::Handle::Offset;
  our @ISA = qw/Tie::Handle::Offset/;
  
  sub TIEHANDLE
  {
    my $class = shift;
    pop if ref $_[-1] eq 'HASH'; # we don't take any arguments
    return $class->SUPER::TIEHANDLE(@_);
  }
  
  # read to blank/whitespace line and set offset right after
  sub OPEN
  {
    my $self = shift;
    my $rc = $self->SUPER::OPEN(@_);
    while ( my $line = <$self> ) {
      last if $line =~ /\A\s*\Z/;
    }
    $self->offset( tell($self) );
    return $rc;
  }
  
  1;
  
  
  # vim: ts=2 sts=2 sw=2 et:
  
  __END__
  =pod
  
  =head1 NAME
  
  Tie::Handle::SkipHeader - Tied handle that hides an RFC822-style header
  
  =head1 VERSION
  
  version 0.003
  
  =head1 SYNOPSIS
  
    use Tie::Handle::SkipHeader;
  
    tie *FH, 'Tie::Handle::SkipHeader', "<", $filename;
  
  =head1 DESCRIPTION
  
  This subclass of L<Tie::Handle::Offset> automatically hides an email-style
  message header.  After opening the file, it reads up to a blank or
  white-space-only line and sets the offset to the next byte.
  
  =for Pod::Coverage method_names_here
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2012 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
  
TIE_HANDLE_SKIPHEADER

$fatpacked{"URI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI';
  package URI;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER);
  
  my %implements;  # mapping from scheme to implementor class
  
  # Some "official" character classes
  
  our $reserved   = q(;/?:@&=+$,[]);
  our $mark       = q(-_.!~*'());                                    #'; emacs
  our $unreserved = "A-Za-z0-9\Q$mark\E";
  our $uric       = quotemeta($reserved) . $unreserved . "%";
  
  our $scheme_re  = '[a-zA-Z][a-zA-Z0-9.+\-]*';
  
  use Carp ();
  use URI::Escape ();
  
  use overload ('""'     => sub { ${$_[0]} },
                '=='     => sub { _obj_eq(@_) },
                '!='     => sub { !_obj_eq(@_) },
                fallback => 1,
               );
  
  # Check if two objects are the same object
  sub _obj_eq {
      return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
  }
  
  sub new
  {
      my($class, $uri, $scheme) = @_;
  
      $uri = defined ($uri) ? "$uri" : "";   # stringify
      # Get rid of potential wrapping
      $uri =~ s/^<(?:URL:)?(.*)>$/$1/;  # 
      $uri =~ s/^"(.*)"$/$1/;
      $uri =~ s/^\s+//;
      $uri =~ s/\s+$//;
  
      my $impclass;
      if ($uri =~ m/^($scheme_re):/so) {
  	$scheme = $1;
      }
      else {
  	if (($impclass = ref($scheme))) {
  	    $scheme = $scheme->scheme;
  	}
  	elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
  	    $scheme = $1;
          }
      }
      $impclass ||= implementor($scheme) ||
  	do {
  	    require URI::_foreign;
  	    $impclass = 'URI::_foreign';
  	};
  
      return $impclass->_init($uri, $scheme);
  }
  
  
  sub new_abs
  {
      my($class, $uri, $base) = @_;
      $uri = $class->new($uri, $base);
      $uri->abs($base);
  }
  
  
  sub _init
  {
      my $class = shift;
      my($str, $scheme) = @_;
      # find all funny characters and encode the bytes.
      $str = $class->_uric_escape($str);
      $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
                                   $class->_no_scheme_ok;
      my $self = bless \$str, $class;
      $self;
  }
  
  
  sub _uric_escape
  {
      my($class, $str) = @_;
      $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
      utf8::downgrade($str);
      return $str;
  }
  
  my %require_attempted;
  
  sub implementor
  {
      my($scheme, $impclass) = @_;
      if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
  	require URI::_generic;
  	return "URI::_generic";
      }
  
      $scheme = lc($scheme);
  
      if ($impclass) {
  	# Set the implementor class for a given scheme
          my $old = $implements{$scheme};
          $impclass->_init_implementor($scheme);
          $implements{$scheme} = $impclass;
          return $old;
      }
  
      my $ic = $implements{$scheme};
      return $ic if $ic;
  
      # scheme not yet known, look for internal or
      # preloaded (with 'use') implementation
      $ic = "URI::$scheme";  # default location
  
      # turn scheme into a valid perl identifier by a simple transformation...
      $ic =~ s/\+/_P/g;
      $ic =~ s/\./_O/g;
      $ic =~ s/\-/_/g;
  
      no strict 'refs';
      # check we actually have one for the scheme:
      unless (@{"${ic}::ISA"}) {
          if (not exists $require_attempted{$ic}) {
              # Try to load it
              my $_old_error = $@;
              eval "require $ic";
              die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
              $@ = $_old_error;
          }
          return undef unless @{"${ic}::ISA"};
      }
  
      $ic->_init_implementor($scheme);
      $implements{$scheme} = $ic;
      $ic;
  }
  
  
  sub _init_implementor
  {
      my($class, $scheme) = @_;
      # Remember that one implementor class may actually
      # serve to implement several URI schemes.
  }
  
  
  sub clone
  {
      my $self = shift;
      my $other = $$self;
      bless \$other, ref $self;
  }
  
  sub TO_JSON { ${$_[0]} }
  
  sub _no_scheme_ok { 0 }
  
  sub _scheme
  {
      my $self = shift;
  
      unless (@_) {
  	return undef unless $$self =~ /^($scheme_re):/o;
  	return $1;
      }
  
      my $old;
      my $new = shift;
      if (defined($new) && length($new)) {
  	Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
  	$old = $1 if $$self =~ s/^($scheme_re)://o;
  	my $newself = URI->new("$new:$$self");
  	$$self = $$newself; 
  	bless $self, ref($newself);
      }
      else {
  	if ($self->_no_scheme_ok) {
  	    $old = $1 if $$self =~ s/^($scheme_re)://o;
  	    Carp::carp("Oops, opaque part now look like scheme")
  		if $^W && $$self =~ m/^$scheme_re:/o
  	}
  	else {
  	    $old = $1 if $$self =~ m/^($scheme_re):/o;
  	}
      }
  
      return $old;
  }
  
  sub scheme
  {
      my $scheme = shift->_scheme(@_);
      return undef unless defined $scheme;
      lc($scheme);
  }
  
  sub has_recognized_scheme {
      my $self = shift;
      return ref($self) !~ /^URI::_(?:foreign|generic)\z/;
  }
  
  sub opaque
  {
      my $self = shift;
  
      unless (@_) {
  	$$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
  	return $1;
      }
  
      $$self =~ /^($scheme_re:)?    # optional scheme
  	        ([^\#]*)          # opaque
                  (\#.*)?           # optional fragment
                $/sx or die;
  
      my $old_scheme = $1;
      my $old_opaque = $2;
      my $old_frag   = $3;
  
      my $new_opaque = shift;
      $new_opaque = "" unless defined $new_opaque;
      $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
      utf8::downgrade($new_opaque);
  
      $$self = defined($old_scheme) ? $old_scheme : "";
      $$self .= $new_opaque;
      $$self .= $old_frag if defined $old_frag;
  
      $old_opaque;
  }
  
  sub path { goto &opaque }  # alias
  
  
  sub fragment
  {
      my $self = shift;
      unless (@_) {
  	return undef unless $$self =~ /\#(.*)/s;
  	return $1;
      }
  
      my $old;
      $old = $1 if $$self =~ s/\#(.*)//s;
  
      my $new_frag = shift;
      if (defined $new_frag) {
  	$new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
  	utf8::downgrade($new_frag);
  	$$self .= "#$new_frag";
      }
      $old;
  }
  
  
  sub as_string
  {
      my $self = shift;
      $$self;
  }
  
  
  sub as_iri
  {
      my $self = shift;
      my $str = $$self;
      if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
  	# All this crap because the more obvious:
  	#
  	#   Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
  	#
  	# doesn't work before Encode 2.39.  Wait for a standard release
  	# to bundle that version.
  
  	require Encode;
  	my $enc = Encode::find_encoding("UTF-8");
  	my $u = "";
  	while (length $str) {
  	    $u .= $enc->decode($str, Encode::FB_QUIET());
  	    if (length $str) {
  		# escape next char
  		$u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
  	    }
  	}
  	$str = $u;
      }
      return $str;
  }
  
  
  sub canonical
  {
      # Make sure scheme is lowercased, that we don't escape unreserved chars,
      # and that we use upcase escape sequences.
  
      my $self = shift;
      my $scheme = $self->_scheme || "";
      my $uc_scheme = $scheme =~ /[A-Z]/;
      my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
      return $self unless $uc_scheme || $esc;
  
      my $other = $self->clone;
      if ($uc_scheme) {
  	$other->_scheme(lc $scheme);
      }
      if ($esc) {
  	$$other =~ s{%([0-9a-fA-F]{2})}
  	            { my $a = chr(hex($1));
                        $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
                      }ge;
      }
      return $other;
  }
  
  # Compare two URIs, subclasses will provide a more correct implementation
  sub eq {
      my($self, $other) = @_;
      $self  = URI->new($self, $other) unless ref $self;
      $other = URI->new($other, $self) unless ref $other;
      ref($self) eq ref($other) &&                # same class
  	$self->canonical->as_string eq $other->canonical->as_string;
  }
  
  # generic-URI transformation methods
  sub abs { $_[0]; }
  sub rel { $_[0]; }
  
  sub secure { 0 }
  
  # help out Storable
  sub STORABLE_freeze {
         my($self, $cloning) = @_;
         return $$self;
  }
  
  sub STORABLE_thaw {
         my($self, $cloning, $str) = @_;
         $$self = $str;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI - Uniform Resource Identifiers (absolute and relative)
  
  =head1 SYNOPSIS
  
   use URI;
  
   $u1 = URI->new("http://www.perl.com");
   $u2 = URI->new("foo", "http");
   $u3 = $u2->abs($u1);
   $u4 = $u3->clone;
   $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical;
  
   $str = $u->as_string;
   $str = "$u";
  
   $scheme = $u->scheme;
   $opaque = $u->opaque;
   $path   = $u->path;
   $frag   = $u->fragment;
  
   $u->scheme("ftp");
   $u->host("ftp.perl.com");
   $u->path("cpan/");
  
  =head1 DESCRIPTION
  
  This module implements the C<URI> class.  Objects of this class
  represent "Uniform Resource Identifier references" as specified in RFC
  2396 (and updated by RFC 2732).
  
  A Uniform Resource Identifier is a compact string of characters that
  identifies an abstract or physical resource.  A Uniform Resource
  Identifier can be further classified as either a Uniform Resource Locator
  (URL) or a Uniform Resource Name (URN).  The distinction between URL
  and URN does not matter to the C<URI> class interface. A
  "URI-reference" is a URI that may have additional information attached
  in the form of a fragment identifier.
  
  An absolute URI reference consists of three parts:  a I<scheme>, a
  I<scheme-specific part> and a I<fragment> identifier.  A subset of URI
  references share a common syntax for hierarchical namespaces.  For
  these, the scheme-specific part is further broken down into
  I<authority>, I<path> and I<query> components.  These URIs can also
  take the form of relative URI references, where the scheme (and
  usually also the authority) component is missing, but implied by the
  context of the URI reference.  The three forms of URI reference
  syntax are summarized as follows:
  
    <scheme>:<scheme-specific-part>#<fragment>
    <scheme>://<authority><path>?<query>#<fragment>
    <path>?<query>#<fragment>
  
  The components into which a URI reference can be divided depend on the
  I<scheme>.  The C<URI> class provides methods to get and set the
  individual components.  The methods available for a specific
  C<URI> object depend on the scheme.
  
  =head1 CONSTRUCTORS
  
  The following methods construct new C<URI> objects:
  
  =over 4
  
  =item $uri = URI->new( $str )
  
  =item $uri = URI->new( $str, $scheme )
  
  Constructs a new URI object.  The string
  representation of a URI is given as argument, together with an optional
  scheme specification.  Common URI wrappers like "" and <>, as well as
  leading and trailing white space, are automatically removed from
  the $str argument before it is processed further.
  
  The constructor determines the scheme, maps this to an appropriate
  URI subclass, constructs a new object of that class and returns it.
  
  If the scheme isn't one of those that URI recognizes, you still get
  an URI object back that you can access the generic methods on.  The
  C<< $uri->has_recognized_scheme >> method can be used to test for
  this.
  
  The $scheme argument is only used when $str is a
  relative URI.  It can be either a simple string that
  denotes the scheme, a string containing an absolute URI reference, or
  an absolute C<URI> object.  If no $scheme is specified for a relative
  URI $str, then $str is simply treated as a generic URI (no scheme-specific
  methods available).
  
  The set of characters available for building URI references is
  restricted (see L<URI::Escape>).  Characters outside this set are
  automatically escaped by the URI constructor.
  
  =item $uri = URI->new_abs( $str, $base_uri )
  
  Constructs a new absolute URI object.  The $str argument can
  denote a relative or absolute URI.  If relative, then it is
  absolutized using $base_uri as base. The $base_uri must be an absolute
  URI.
  
  =item $uri = URI::file->new( $filename )
  
  =item $uri = URI::file->new( $filename, $os )
  
  Constructs a new I<file> URI from a file name.  See L<URI::file>.
  
  =item $uri = URI::file->new_abs( $filename )
  
  =item $uri = URI::file->new_abs( $filename, $os )
  
  Constructs a new absolute I<file> URI from a file name.  See
  L<URI::file>.
  
  =item $uri = URI::file->cwd
  
  Returns the current working directory as a I<file> URI.  See
  L<URI::file>.
  
  =item $uri->clone
  
  Returns a copy of the $uri.
  
  =back
  
  =head1 COMMON METHODS
  
  The methods described in this section are available for all C<URI>
  objects.
  
  Methods that give access to components of a URI always return the
  old value of the component.  The value returned is C<undef> if the
  component was not present.  There is generally a difference between a
  component that is empty (represented as C<"">) and a component that is
  missing (represented as C<undef>).  If an accessor method is given an
  argument, it updates the corresponding component in addition to
  returning the old value of the component.  Passing an undefined
  argument removes the component (if possible).  The description of
  each accessor method indicates whether the component is passed as
  an escaped (percent-encoded) or an unescaped string.  A component that can be further
  divided into sub-parts are usually passed escaped, as unescaping might
  change its semantics.
  
  The common methods available for all URI are:
  
  =over 4
  
  =item $uri->scheme
  
  =item $uri->scheme( $new_scheme )
  
  Sets and returns the scheme part of the $uri.  If the $uri is
  relative, then $uri->scheme returns C<undef>.  If called with an
  argument, it updates the scheme of $uri, possibly changing the
  class of $uri, and returns the old scheme value.  The method croaks
  if the new scheme name is illegal; a scheme name must begin with a
  letter and must consist of only US-ASCII letters, numbers, and a few
  special marks: ".", "+", "-".  This restriction effectively means
  that the scheme must be passed unescaped.  Passing an undefined
  argument to the scheme method makes the URI relative (if possible).
  
  Letter case does not matter for scheme names.  The string
  returned by $uri->scheme is always lowercase.  If you want the scheme
  just as it was written in the URI in its original case,
  you can use the $uri->_scheme method instead.
  
  =item $uri->has_recognized_scheme
  
  Returns TRUE if the URI scheme is one that URI recognizes.
  
  It will also be TRUE for relative URLs where a recognized
  scheme was provided to the constructor, even if C<< $uri->scheme >>
  returns C<undef> for these.
  
  =item $uri->opaque
  
  =item $uri->opaque( $new_opaque )
  
  Sets and returns the scheme-specific part of the $uri
  (everything between the scheme and the fragment)
  as an escaped string.
  
  =item $uri->path
  
  =item $uri->path( $new_path )
  
  Sets and returns the same value as $uri->opaque unless the URI
  supports the generic syntax for hierarchical namespaces.
  In that case the generic method is overridden to set and return
  the part of the URI between the I<host name> and the I<fragment>.
  
  =item $uri->fragment
  
  =item $uri->fragment( $new_frag )
  
  Returns the fragment identifier of a URI reference
  as an escaped string.
  
  =item $uri->as_string
  
  Returns a URI object to a plain ASCII string.  URI objects are
  also converted to plain strings automatically by overloading.  This
  means that $uri objects can be used as plain strings in most Perl
  constructs.
  
  =item $uri->as_iri
  
  Returns a Unicode string representing the URI.  Escaped UTF-8 sequences
  representing non-ASCII characters are turned into their corresponding Unicode
  code point.
  
  =item $uri->canonical
  
  Returns a normalized version of the URI.  The rules
  for normalization are scheme-dependent.  They usually involve
  lowercasing the scheme and Internet host name components,
  removing the explicit port specification if it matches the default port,
  uppercasing all escape sequences, and unescaping octets that can be
  better represented as plain characters.
  
  For efficiency reasons, if the $uri is already in normalized form,
  then a reference to it is returned instead of a copy.
  
  =item $uri->eq( $other_uri )
  
  =item URI::eq( $first_uri, $other_uri )
  
  Tests whether two URI references are equal.  URI references
  that normalize to the same string are considered equal.  The method
  can also be used as a plain function which can also test two string
  arguments.
  
  If you need to test whether two C<URI> object references denote the
  same object, use the '==' operator.
  
  =item $uri->abs( $base_uri )
  
  Returns an absolute URI reference.  If $uri is already
  absolute, then a reference to it is simply returned.  If the $uri
  is relative, then a new absolute URI is constructed by combining the
  $uri and the $base_uri, and returned.
  
  =item $uri->rel( $base_uri )
  
  Returns a relative URI reference if it is possible to
  make one that denotes the same resource relative to $base_uri.
  If not, then $uri is simply returned.
  
  =item $uri->secure
  
  Returns a TRUE value if the URI is considered to point to a resource on
  a secure channel, such as an SSL or TLS encrypted one.
  
  =back
  
  =head1 GENERIC METHODS
  
  The following methods are available to schemes that use the
  common/generic syntax for hierarchical namespaces.  The descriptions of
  schemes below indicate which these are.  Unrecognized schemes are
  assumed to support the generic syntax, and therefore the following
  methods:
  
  =over 4
  
  =item $uri->authority
  
  =item $uri->authority( $new_authority )
  
  Sets and returns the escaped authority component
  of the $uri.
  
  =item $uri->path
  
  =item $uri->path( $new_path )
  
  Sets and returns the escaped path component of
  the $uri (the part between the host name and the query or fragment).
  The path can never be undefined, but it can be the empty string.
  
  =item $uri->path_query
  
  =item $uri->path_query( $new_path_query )
  
  Sets and returns the escaped path and query
  components as a single entity.  The path and the query are
  separated by a "?" character, but the query can itself contain "?".
  
  =item $uri->path_segments
  
  =item $uri->path_segments( $segment, ... )
  
  Sets and returns the path.  In a scalar context, it returns
  the same value as $uri->path.  In a list context, it returns the
  unescaped path segments that make up the path.  Path segments that
  have parameters are returned as an anonymous array.  The first element
  is the unescaped path segment proper;  subsequent elements are escaped
  parameter strings.  Such an anonymous array uses overloading so it can
  be treated as a string too, but this string does not include the
  parameters.
  
  Note that absolute paths have the empty string as their first
  I<path_segment>, i.e. the I<path> C</foo/bar> have 3
  I<path_segments>; "", "foo" and "bar".
  
  =item $uri->query
  
  =item $uri->query( $new_query )
  
  Sets and returns the escaped query component of
  the $uri.
  
  =item $uri->query_form
  
  =item $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
  
  =item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim )
  
  =item $uri->query_form( \@key_value_pairs )
  
  =item $uri->query_form( \@key_value_pairs, $delim )
  
  =item $uri->query_form( \%hash )
  
  =item $uri->query_form( \%hash, $delim )
  
  Sets and returns query components that use the
  I<application/x-www-form-urlencoded> format.  Key/value pairs are
  separated by "&", and the key is separated from the value by a "="
  character.
  
  The form can be set either by passing separate key/value pairs, or via
  an array or hash reference.  Passing an empty array or an empty hash
  removes the query component, whereas passing no arguments at all leaves
  the component unchanged.  The order of keys is undefined if a hash
  reference is passed.  The old value is always returned as a list of
  separate key/value pairs.  Assigning this list to a hash is unwise as
  the keys returned might repeat.
  
  The values passed when setting the form can be plain strings or
  references to arrays of strings.  Passing an array of values has the
  same effect as passing the key repeatedly with one value at a time.
  All the following statements have the same effect:
  
      $uri->query_form(foo => 1, foo => 2);
      $uri->query_form(foo => [1, 2]);
      $uri->query_form([ foo => 1, foo => 2 ]);
      $uri->query_form([ foo => [1, 2] ]);
      $uri->query_form({ foo => [1, 2] });
  
  The $delim parameter can be passed as ";" to force the key/value pairs
  to be delimited by ";" instead of "&" in the query string.  This
  practice is often recommended for URLs embedded in HTML or XML
  documents as this avoids the trouble of escaping the "&" character.
  You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to
  ";" for the same global effect.
  
  The C<URI::QueryParam> module can be loaded to add further methods to
  manipulate the form of a URI.  See L<URI::QueryParam> for details.
  
  =item $uri->query_keywords
  
  =item $uri->query_keywords( $keywords, ... )
  
  =item $uri->query_keywords( \@keywords )
  
  Sets and returns query components that use the
  keywords separated by "+" format.
  
  The keywords can be set either by passing separate keywords directly
  or by passing a reference to an array of keywords.  Passing an empty
  array removes the query component, whereas passing no arguments at
  all leaves the component unchanged.  The old value is always returned
  as a list of separate words.
  
  =back
  
  =head1 SERVER METHODS
  
  For schemes where the I<authority> component denotes an Internet host,
  the following methods are available in addition to the generic
  methods.
  
  =over 4
  
  =item $uri->userinfo
  
  =item $uri->userinfo( $new_userinfo )
  
  Sets and returns the escaped userinfo part of the
  authority component.
  
  For some schemes this is a user name and a password separated by
  a colon.  This practice is not recommended. Embedding passwords in
  clear text (such as URI) has proven to be a security risk in almost
  every case where it has been used.
  
  =item $uri->host
  
  =item $uri->host( $new_host )
  
  Sets and returns the unescaped hostname.
  
  If the $new_host string ends with a colon and a number, then this
  number also sets the port.
  
  For IPv6 addresses the brackets around the raw address is removed in the return
  value from $uri->host.  When setting the host attribute to an IPv6 address you
  can use a raw address or one enclosed in brackets.  The address needs to be
  enclosed in brackets if you want to pass in a new port value as well.
  
  =item $uri->ihost
  
  Returns the host in Unicode form.  Any IDNA A-labels are turned into U-labels.
  
  =item $uri->port
  
  =item $uri->port( $new_port )
  
  Sets and returns the port.  The port is a simple integer
  that should be greater than 0.
  
  If a port is not specified explicitly in the URI, then the URI scheme's default port
  is returned. If you don't want the default port
  substituted, then you can use the $uri->_port method instead.
  
  =item $uri->host_port
  
  =item $uri->host_port( $new_host_port )
  
  Sets and returns the host and port as a single
  unit.  The returned value includes a port, even if it matches the
  default port.  The host part and the port part are separated by a
  colon: ":".
  
  For IPv6 addresses the bracketing is preserved; thus
  URI->new("http://[::1]/")->host_port returns "[::1]:80".  Contrast this with
  $uri->host which will remove the brackets.
  
  =item $uri->default_port
  
  Returns the default port of the URI scheme to which $uri
  belongs.  For I<http> this is the number 80, for I<ftp> this
  is the number 21, etc.  The default port for a scheme can not be
  changed.
  
  =back
  
  =head1 SCHEME-SPECIFIC SUPPORT
  
  Scheme-specific support is provided for the following URI schemes.  For C<URI>
  objects that do not belong to one of these, you can only use the common and
  generic methods.
  
  =over 4
  
  =item B<data>:
  
  The I<data> URI scheme is specified in RFC 2397.  It allows inclusion
  of small data items as "immediate" data, as if it had been included
  externally.
  
  C<URI> objects belonging to the data scheme support the common methods
  and two new methods to access their scheme-specific components:
  $uri->media_type and $uri->data.  See L<URI::data> for details.
  
  =item B<file>:
  
  An old specification of the I<file> URI scheme is found in RFC 1738.
  A new RFC 2396 based specification in not available yet, but file URI
  references are in common use.
  
  C<URI> objects belonging to the file scheme support the common and
  generic methods.  In addition, they provide two methods for mapping file URIs
  back to local file names; $uri->file and $uri->dir.  See L<URI::file>
  for details.
  
  =item B<ftp>:
  
  An old specification of the I<ftp> URI scheme is found in RFC 1738.  A
  new RFC 2396 based specification in not available yet, but ftp URI
  references are in common use.
  
  C<URI> objects belonging to the ftp scheme support the common,
  generic and server methods.  In addition, they provide two methods for
  accessing the userinfo sub-components: $uri->user and $uri->password.
  
  =item B<gopher>:
  
  The I<gopher> URI scheme is specified in
  <draft-murali-url-gopher-1996-12-04> and will hopefully be available
  as a RFC 2396 based specification.
  
  C<URI> objects belonging to the gopher scheme support the common,
  generic and server methods. In addition, they support some methods for
  accessing gopher-specific path components: $uri->gopher_type,
  $uri->selector, $uri->search, $uri->string.
  
  =item B<http>:
  
  The I<http> URI scheme is specified in RFC 2616.
  The scheme is used to reference resources hosted by HTTP servers.
  
  C<URI> objects belonging to the http scheme support the common,
  generic and server methods.
  
  =item B<https>:
  
  The I<https> URI scheme is a Netscape invention which is commonly
  implemented.  The scheme is used to reference HTTP servers through SSL
  connections.  Its syntax is the same as http, but the default
  port is different.
  
  =item B<ldap>:
  
  The I<ldap> URI scheme is specified in RFC 2255.  LDAP is the
  Lightweight Directory Access Protocol.  An ldap URI describes an LDAP
  search operation to perform to retrieve information from an LDAP
  directory.
  
  C<URI> objects belonging to the ldap scheme support the common,
  generic and server methods as well as ldap-specific methods: $uri->dn,
  $uri->attributes, $uri->scope, $uri->filter, $uri->extensions.  See
  L<URI::ldap> for details.
  
  =item B<ldapi>:
  
  Like the I<ldap> URI scheme, but uses a UNIX domain socket.  The
  server methods are not supported, and the local socket path is
  available as $uri->un_path.  The I<ldapi> scheme is used by the
  OpenLDAP package.  There is no real specification for it, but it is
  mentioned in various OpenLDAP manual pages.
  
  =item B<ldaps>:
  
  Like the I<ldap> URI scheme, but uses an SSL connection.  This
  scheme is deprecated, as the preferred way is to use the I<start_tls>
  mechanism.
  
  =item B<mailto>:
  
  The I<mailto> URI scheme is specified in RFC 2368.  The scheme was
  originally used to designate the Internet mailing address of an
  individual or service.  It has (in RFC 2368) been extended to allow
  setting of other mail header fields and the message body.
  
  C<URI> objects belonging to the mailto scheme support the common
  methods and the generic query methods.  In addition, they support the
  following mailto-specific methods: $uri->to, $uri->headers.
  
  Note that the "foo@example.com" part of a mailto is I<not> the
  C<userinfo> and C<host> but instead the C<path>.  This allows a
  mailto URI to contain multiple comma separated email addresses.
  
  =item B<mms>:
  
  The I<mms> URL specification can be found at L<http://sdp.ppona.com/>.
  C<URI> objects belonging to the mms scheme support the common,
  generic, and server methods, with the exception of userinfo and
  query-related sub-components.
  
  =item B<news>:
  
  The I<news>, I<nntp> and I<snews> URI schemes are specified in
  <draft-gilman-news-url-01> and will hopefully be available as an RFC
  2396 based specification soon.
  
  C<URI> objects belonging to the news scheme support the common,
  generic and server methods.  In addition, they provide some methods to
  access the path: $uri->group and $uri->message.
  
  =item B<nntp>:
  
  See I<news> scheme.
  
  =item B<pop>:
  
  The I<pop> URI scheme is specified in RFC 2384. The scheme is used to
  reference a POP3 mailbox.
  
  C<URI> objects belonging to the pop scheme support the common, generic
  and server methods.  In addition, they provide two methods to access the
  userinfo components: $uri->user and $uri->auth
  
  =item B<rlogin>:
  
  An old specification of the I<rlogin> URI scheme is found in RFC
  1738. C<URI> objects belonging to the rlogin scheme support the
  common, generic and server methods.
  
  =item B<rtsp>:
  
  The I<rtsp> URL specification can be found in section 3.2 of RFC 2326.
  C<URI> objects belonging to the rtsp scheme support the common,
  generic, and server methods, with the exception of userinfo and
  query-related sub-components.
  
  =item B<rtspu>:
  
  The I<rtspu> URI scheme is used to talk to RTSP servers over UDP
  instead of TCP.  The syntax is the same as rtsp.
  
  =item B<rsync>:
  
  Information about rsync is available from L<http://rsync.samba.org/>.
  C<URI> objects belonging to the rsync scheme support the common,
  generic and server methods.  In addition, they provide methods to
  access the userinfo sub-components: $uri->user and $uri->password.
  
  =item B<sip>:
  
  The I<sip> URI specification is described in sections 19.1 and 25
  of RFC 3261.  C<URI> objects belonging to the sip scheme support the
  common, generic, and server methods with the exception of path related
  sub-components.  In addition, they provide two methods to get and set
  I<sip> parameters: $uri->params_form and $uri->params.
  
  =item B<sips>:
  
  See I<sip> scheme.  Its syntax is the same as sip, but the default
  port is different.
  
  =item B<snews>:
  
  See I<news> scheme.  Its syntax is the same as news, but the default
  port is different.
  
  =item B<telnet>:
  
  An old specification of the I<telnet> URI scheme is found in RFC
  1738. C<URI> objects belonging to the telnet scheme support the
  common, generic and server methods.
  
  =item B<tn3270>:
  
  These URIs are used like I<telnet> URIs but for connections to IBM
  mainframes.  C<URI> objects belonging to the tn3270 scheme support the
  common, generic and server methods.
  
  =item B<ssh>:
  
  Information about ssh is available at L<http://www.openssh.com/>.
  C<URI> objects belonging to the ssh scheme support the common,
  generic and server methods. In addition, they provide methods to
  access the userinfo sub-components: $uri->user and $uri->password.
  
  =item B<sftp>:
  
  C<URI> objects belonging to the sftp scheme support the common,
  generic and server methods. In addition, they provide methods to
  access the userinfo sub-components: $uri->user and $uri->password.
  
  =item B<urn>:
  
  The syntax of Uniform Resource Names is specified in RFC 2141.  C<URI>
  objects belonging to the urn scheme provide the common methods, and also the
  methods $uri->nid and $uri->nss, which return the Namespace Identifier
  and the Namespace-Specific String respectively.
  
  The Namespace Identifier basically works like the Scheme identifier of
  URIs, and further divides the URN namespace.  Namespace Identifier
  assignments are maintained at
  L<http://www.iana.org/assignments/urn-namespaces>.
  
  Letter case is not significant for the Namespace Identifier.  It is
  always returned in lower case by the $uri->nid method.  The $uri->_nid
  method can be used if you want it in its original case.
  
  =item B<urn>:B<isbn>:
  
  The C<urn:isbn:> namespace contains International Standard Book
  Numbers (ISBNs) and is described in RFC 3187.  A C<URI> object belonging
  to this namespace has the following extra methods (if the
  Business::ISBN module is available): $uri->isbn,
  $uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code,
  which is still supported by issues a deprecation warning), $uri->isbn_as_ean.
  
  =item B<urn>:B<oid>:
  
  The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is
  described in RFC 3061.  An object identifier consists of sequences of digits
  separated by dots.  A C<URI> object belonging to this namespace has an
  additional method called $uri->oid that can be used to get/set the oid
  value.  In a list context, oid numbers are returned as separate elements.
  
  =back
  
  =head1 CONFIGURATION VARIABLES
  
  The following configuration variables influence how the class and its
  methods behave:
  
  =over 4
  
  =item $URI::ABS_ALLOW_RELATIVE_SCHEME
  
  Some older parsers used to allow the scheme name to be present in the
  relative URL if it was the same as the base URL scheme.  RFC 2396 says
  that this should be avoided, but you can enable this old behaviour by
  setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value.
  The difference is demonstrated by the following examples:
  
    URI->new("http:foo")->abs("http://host/a/b")
        ==>  "http:foo"
  
    local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
    URI->new("http:foo")->abs("http://host/a/b")
        ==>  "http:/host/a/foo"
  
  
  =item $URI::ABS_REMOTE_LEADING_DOTS
  
  You can also have the abs() method ignore excess ".."
  segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS
  to a TRUE value.  The difference is demonstrated by the following
  examples:
  
    URI->new("../../../foo")->abs("http://host/a/b")
        ==> "http://host/../../foo"
  
    local $URI::ABS_REMOTE_LEADING_DOTS = 1;
    URI->new("../../../foo")->abs("http://host/a/b")
        ==> "http://host/foo"
  
  =item $URI::DEFAULT_QUERY_FORM_DELIMITER
  
  This value can be set to ";" to have the query form C<key=value> pairs
  delimited by ";" instead of "&" which is the default.
  
  =back
  
  =head1 BUGS
  
  There are some things that are not quite right:
  
  =over
  
  =item *
  
  Using regexp variables like $1 directly as arguments to the URI accessor methods
  does not work too well with current perl implementations.  I would argue
  that this is actually a bug in perl.  The workaround is to quote
  them. Example:
  
     /(...)/ || die;
     $u->query("$1");
  
  
  =item *
  
  The escaping (percent encoding) of chars in the 128 .. 255 range passed to the
  URI constructor or when setting URI parts using the accessor methods depend on
  the state of the internal UTF8 flag (see utf8::is_utf8) of the string passed.
  If the UTF8 flag is set the UTF-8 encoded version of the character is percent
  encoded.  If the UTF8 flag isn't set the Latin-1 version (byte) of the
  character is percent encoded.  This basically exposes the internal encoding of
  Perl strings.
  
  =back
  
  =head1 PARSING URIs WITH REGEXP
  
  As an alternative to this module, the following (official) regular
  expression can be used to decode a URI:
  
    my($scheme, $authority, $path, $query, $fragment) =
    $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
  
  The C<URI::Split> module provides the function uri_split() as a
  readable alternative.
  
  =head1 SEE ALSO
  
  L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>,
  L<URI::Split>, L<URI::Heuristic>
  
  RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax",
  Berners-Lee, Fielding, Masinter, August 1998.
  
  L<http://www.iana.org/assignments/uri-schemes>
  
  L<http://www.iana.org/assignments/urn-namespaces>
  
  L<http://www.w3.org/Addressing/>
  
  =head1 COPYRIGHT
  
  Copyright 1995-2009 Gisle Aas.
  
  Copyright 1995 Martijn Koster.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 AUTHORS / ACKNOWLEDGMENTS
  
  This module is based on the C<URI::URL> module, which in turn was
  (distantly) based on the C<wwwurl.pl> code in the libwww-perl for
  perl4 developed by Roy Fielding, as part of the Arcadia project at the
  University of California, Irvine, with contributions from Brooks
  Cutter.
  
  C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and
  Martijn Koster with input from other people on the libwww-perl mailing
  list.
  
  C<URI> and related subclasses was developed by Gisle Aas.
  
  =cut
URI

$fatpacked{"URI/Escape.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_ESCAPE';
  package URI::Escape;
  
  use strict;
  use warnings;
  
  =head1 NAME
  
  URI::Escape - Percent-encode and percent-decode unsafe characters
  
  =head1 SYNOPSIS
  
   use URI::Escape;
   $safe = uri_escape("10% is enough\n");
   $verysafe = uri_escape("foo", "\0-\377");
   $str  = uri_unescape($safe);
  
  =head1 DESCRIPTION
  
  This module provides functions to percent-encode and percent-decode URI strings as
  defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping".
  This is the terminology used by this module, which predates the formalization of the
  terms by the RFC by several years.
  
  A URI consists of a restricted set of characters.  The restricted set
  of characters consists of digits, letters, and a few graphic symbols
  chosen from those common to most of the character encodings and input
  facilities available to Internet users.  They are made up of the
  "unreserved" and "reserved" character sets as defined in RFC 3986.
  
     unreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~"
     reserved      = ":" / "/" / "?" / "#" / "[" / "]" / "@"
                     "!" / "$" / "&" / "'" / "(" / ")"
                   / "*" / "+" / "," / ";" / "="
  
  In addition, any byte (octet) can be represented in a URI by an escape
  sequence: a triplet consisting of the character "%" followed by two
  hexadecimal digits.  A byte can also be represented directly by a
  character, using the US-ASCII character for that octet.
  
  Some of the characters are I<reserved> for use as delimiters or as
  part of certain URI components.  These must be escaped if they are to
  be treated as ordinary data.  Read RFC 3986 for further details.
  
  The functions provided (and exported by default) from this module are:
  
  =over 4
  
  =item uri_escape( $string )
  
  =item uri_escape( $string, $unsafe )
  
  Replaces each unsafe character in the $string with the corresponding
  escape sequence and returns the result.  The $string argument should
  be a string of bytes.  The uri_escape() function will croak if given a
  characters with code above 255.  Use uri_escape_utf8() if you know you
  have such chars or/and want chars in the 128 .. 255 range treated as
  UTF-8.
  
  The uri_escape() function takes an optional second argument that
  overrides the set of characters that are to be escaped.  The set is
  specified as a string that can be used in a regular expression
  character class (between [ ]).  E.g.:
  
    "\x00-\x1f\x7f-\xff"          # all control and hi-bit characters
    "a-z"                         # all lower case characters
    "^A-Za-z"                     # everything not a letter
  
  The default set of characters to be escaped is all those which are
  I<not> part of the C<unreserved> character class shown above as well
  as the reserved characters.  I.e. the default is:
  
      "^A-Za-z0-9\-\._~"
  
  =item uri_escape_utf8( $string )
  
  =item uri_escape_utf8( $string, $unsafe )
  
  Works like uri_escape(), but will encode chars as UTF-8 before
  escaping them.  This makes this function able to deal with characters
  with code above 255 in $string.  Note that chars in the 128 .. 255
  range will be escaped differently by this function compared to what
  uri_escape() would.  For chars in the 0 .. 127 range there is no
  difference.
  
  Equivalent to:
  
      utf8::encode($string);
      my $uri = uri_escape($string);
  
  Note: JavaScript has a function called escape() that produces the
  sequence "%uXXXX" for chars in the 256 .. 65535 range.  This function
  has really nothing to do with URI escaping but some folks got confused
  since it "does the right thing" in the 0 .. 255 range.  Because of
  this you sometimes see "URIs" with these kind of escapes.  The
  JavaScript encodeURIComponent() function is similar to uri_escape_utf8().
  
  =item uri_unescape($string,...)
  
  Returns a string with each %XX sequence replaced with the actual byte
  (octet).
  
  This does the same as:
  
     $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  
  but does not modify the string in-place as this RE would.  Using the
  uri_unescape() function instead of the RE might make the code look
  cleaner and is a few characters less to type.
  
  In a simple benchmark test I did,
  calling the function (instead of the inline RE above) if a few chars
  were unescaped was something like 40% slower, and something like 700% slower if none were.  If
  you are going to unescape a lot of times it might be a good idea to
  inline the RE.
  
  If the uri_unescape() function is passed multiple strings, then each
  one is returned unescaped.
  
  =back
  
  The module can also export the C<%escapes> hash, which contains the
  mapping from all 256 bytes to the corresponding escape codes.  Lookup
  in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))>
  each time.
  
  =head1 SEE ALSO
  
  L<URI>
  
  
  =head1 COPYRIGHT
  
  Copyright 1995-2004 Gisle Aas.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
  
  use Exporter 5.57 'import';
  our %escapes;
  our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8);
  our @EXPORT_OK = qw(%escapes);
  our $VERSION = "3.31";
  
  use Carp ();
  
  # Build a char->hex map
  for (0..255) {
      $escapes{chr($_)} = sprintf("%%%02X", $_);
  }
  
  my %subst;  # compiled patterns
  
  my %Unsafe = (
      RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/,
      RFC3986 => qr/[^A-Za-z0-9\-\._~]/,
  );
  
  sub uri_escape {
      my($text, $patn) = @_;
      return undef unless defined $text;
      if (defined $patn){
          unless (exists  $subst{$patn}) {
              # Because we can't compile the regex we fake it with a cached sub
              (my $tmp = $patn) =~ s,/,\\/,g;
              eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }";
              Carp::croak("uri_escape: $@") if $@;
          }
          &{$subst{$patn}}($text);
      } else {
          $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge;
      }
      $text;
  }
  
  sub _fail_hi {
      my $chr = shift;
      Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr));
  }
  
  sub uri_escape_utf8 {
      my $text = shift;
      return undef unless defined $text;
      utf8::encode($text);
      return uri_escape($text, @_);
  }
  
  sub uri_unescape {
      # Note from RFC1630:  "Sequences which start with a percent sign
      # but are not followed by two hexadecimal characters are reserved
      # for future extension"
      my $str = shift;
      if (@_ && wantarray) {
          # not executed for the common case of a single argument
          my @str = ($str, @_);  # need to copy
          for (@str) {
              s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
          }
          return @str;
      }
      $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str;
      $str;
  }
  
  # XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format.
  sub escape_char {
      # Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1).
      # The following forces a fetch to occur beforehand.
      my $dummy = substr($_[0], 0, 0);
  
      if (utf8::is_utf8($_[0])) {
          my $s = shift;
          utf8::encode($s);
          unshift(@_, $s);
      }
  
      return join '', @URI::Escape::escapes{split //, $_[0]};
  }
  
  1;
URI_ESCAPE

$fatpacked{"URI/Heuristic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_HEURISTIC';
  package URI::Heuristic;
  
  =head1 NAME
  
  URI::Heuristic - Expand URI using heuristics
  
  =head1 SYNOPSIS
  
   use URI::Heuristic qw(uf_uristr);
   $u = uf_uristr("perl");             # http://www.perl.com
   $u = uf_uristr("www.sol.no/sol");   # http://www.sol.no/sol
   $u = uf_uristr("aas");              # http://www.aas.no
   $u = uf_uristr("ftp.funet.fi");     # ftp://ftp.funet.fi
   $u = uf_uristr("/etc/passwd");      # file:/etc/passwd
  
  =head1 DESCRIPTION
  
  This module provides functions that expand strings into real absolute
  URIs using some built-in heuristics.  Strings that already represent
  absolute URIs (i.e. that start with a C<scheme:> part) are never modified
  and are returned unchanged.  The main use of these functions is to
  allow abbreviated URIs similar to what many web browsers allow for URIs
  typed in by the user.
  
  The following functions are provided:
  
  =over 4
  
  =item uf_uristr($str)
  
  Tries to make the argument string
  into a proper absolute URI string.  The "uf_" prefix stands for "User 
  Friendly".  Under MacOS, it assumes that any string with a common URL 
  scheme (http, ftp, etc.) is a URL rather than a local path.  So don't name 
  your volumes after common URL schemes and expect uf_uristr() to construct 
  valid file: URL's on those volumes for you, because it won't.
  
  =item uf_uri($str)
  
  Works the same way as uf_uristr() but
  returns a C<URI> object.
  
  =back
  
  =head1 ENVIRONMENT
  
  If the hostname portion of a URI does not contain any dots, then
  certain qualified guesses are made.  These guesses are governed by
  the following environment variables:
  
  =over 10
  
  =item COUNTRY
  
  The two-letter country code (ISO 3166) for your location.  If
  the domain name of your host ends with two letters, then it is taken
  to be the default country. See also L<Locale::Country>.
  
  =item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG
  
  If COUNTRY is not set, these standard environment variables are
  examined and country (not language) information possibly found in them
  is used as the default country.
  
  =item URL_GUESS_PATTERN
  
  Contains a space-separated list of URL patterns to try.  The string
  "ACME" is for some reason used as a placeholder for the host name in
  the URL provided.  Example:
  
   URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com"
   export URL_GUESS_PATTERN
  
  Specifying URL_GUESS_PATTERN disables any guessing rules based on
  country.  An empty URL_GUESS_PATTERN disables any guessing that
  involves host name lookups.
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright 1997-1998, Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
  
  use strict;
  use warnings;
  
  use Exporter 5.57 'import';
  our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr);
  our $VERSION = "4.20";
  
  our ($MY_COUNTRY, $DEBUG);
  
  sub MY_COUNTRY() {
      for ($MY_COUNTRY) {
  	return $_ if defined;
  
  	# First try the environment.
  	$_ = $ENV{COUNTRY};
  	return $_ if defined;
  
  	# Try the country part of LC_ALL and LANG from environment
  	my @srcs = ($ENV{LC_ALL}, $ENV{LANG});
  	# ...and HTTP_ACCEPT_LANGUAGE before those if present
  	if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) {
  	    # TODO: q-value processing/ordering
  	    for $httplang (split(/\s*,\s*/, $httplang)) {
  		if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) {
  		    unshift(@srcs, "${1}_${2}");
  		    last;
  		}
  	    }
  	}
  	for (@srcs) {
  	    next unless defined;
  	    return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/;
  	}
  
  	# Last bit of domain name.  This may access the network.
  	require Net::Domain;
  	my $fqdn = Net::Domain::hostfqdn();
  	$_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/;
  	return $_ if defined;
  
  	# Give up.  Defined but false.
  	return ($_ = 0);
      }
  }
  
  our %LOCAL_GUESSING =
  (
   'us' => [qw(www.ACME.gov www.ACME.mil)],
   'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)],
   'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)],
   'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)],
   # send corrections and new entries to <gisle@aas.no>
  );
  # Backwards compatibility; uk != United Kingdom in ISO 3166
  $LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb};
  
  
  sub uf_uristr ($)
  {
      local($_) = @_;
      print STDERR "uf_uristr: resolving $_\n" if $DEBUG;
      return unless defined;
  
      s/^\s+//;
      s/\s+$//;
  
      if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) {
  	$_ = "http://$_";
  
      } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) {
  	$_ = lc($1) . "://$_";
  
      } elsif ($^O ne "MacOS" && 
  	    (m,^/,      ||          # absolute file name
  	     m,^\.\.?/, ||          # relative file name
  	     m,^[a-zA-Z]:[/\\],)    # dosish file name
  	    )
      {
  	$_ = "file:$_";
  
      } elsif ($^O eq "MacOS" && m/:/) {
          # potential MacOS file name
  	unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) {
  	    require URI::file;
  	    my $a = URI::file->new($_)->as_string;
  	    $_ = ($a =~ m/^file:/) ? $a : "file:$a";
  	}
      } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) {
  	$_ = "mailto:$_";
  
      } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) {      # no scheme specified
  	if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) {
  	    my $host = $1;
  
  	    my $scheme = "http";
  	    if (/^:(\d+)\b/) {
  		# Some more or less well known ports
  		if ($1 =~ /^[56789]?443$/) {
  		    $scheme = "https";
  		} elsif ($1 eq "21") {
  		    $scheme = "ftp";
  		}
  	    }
  
  	    if ($host !~ /\./ && $host ne "localhost") {
  		my @guess;
  		if (exists $ENV{URL_GUESS_PATTERN}) {
  		    @guess = map { s/\bACME\b/$host/; $_ }
  		             split(' ', $ENV{URL_GUESS_PATTERN});
  		} else {
  		    if (MY_COUNTRY()) {
  			my $special = $LOCAL_GUESSING{MY_COUNTRY()};
  			if ($special) {
  			    my @special = @$special;
  			    push(@guess, map { s/\bACME\b/$host/; $_ }
                                                 @special);
  			} else {
  			    push(@guess, "www.$host." . MY_COUNTRY());
  			}
  		    }
  		    push(@guess, map "www.$host.$_",
  			             "com", "org", "net", "edu", "int");
  		}
  
  
  		my $guess;
  		for $guess (@guess) {
  		    print STDERR "uf_uristr: gethostbyname('$guess.')..."
  		      if $DEBUG;
  		    if (gethostbyname("$guess.")) {
  			print STDERR "yes\n" if $DEBUG;
  			$host = $guess;
  			last;
  		    }
  		    print STDERR "no\n" if $DEBUG;
  		}
  	    }
  	    $_ = "$scheme://$host$_";
  
  	} else {
  	    # pure junk, just return it unchanged...
  
  	}
      }
      print STDERR "uf_uristr: ==> $_\n" if $DEBUG;
  
      $_;
  }
  
  sub uf_uri ($)
  {
      require URI;
      URI->new(uf_uristr($_[0]));
  }
  
  # legacy
  *uf_urlstr = \*uf_uristr;
  
  sub uf_url ($)
  {
      require URI::URL;
      URI::URL->new(uf_uristr($_[0]));
  }
  
  1;
URI_HEURISTIC

$fatpacked{"URI/IRI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_IRI';
  package URI::IRI;
  
  # Experimental
  
  use strict;
  use warnings;
  use URI ();
  
  use overload '""' => sub { shift->as_string };
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub new {
      my($class, $uri, $scheme) = @_;
      utf8::upgrade($uri);
      return bless {
  	uri => URI->new($uri, $scheme),
      }, $class;
  }
  
  sub clone {
      my $self = shift;
      return bless {
  	uri => $self->{uri}->clone,
      }, ref($self);
  }
  
  sub as_string {
      my $self = shift;
      return $self->{uri}->as_iri;
  }
  
  our $AUTOLOAD;
  sub AUTOLOAD
  {
      my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
  
      # We create the function here so that it will not need to be
      # autoloaded the next time.
      no strict 'refs';
      *$method = sub { shift->{uri}->$method(@_) };
      goto &$method;
  }
  
  sub DESTROY {}   # avoid AUTOLOADing it
  
  1;
URI_IRI

$fatpacked{"URI/QueryParam.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_QUERYPARAM';
  package URI::QueryParam;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub URI::_query::query_param {
      my $self = shift;
      my @old = $self->query_form;
  
      if (@_ == 0) {
  	# get keys
  	my (%seen, $i);
  	return grep !($i++ % 2 || $seen{$_}++), @old;
      }
  
      my $key = shift;
      my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old;
  
      if (@_) {
  	my @new = @old;
  	my @new_i = @i;
  	my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
  
  	while (@new_i > @vals) {
  	    splice @new, pop @new_i, 2;
  	}
  	if (@vals > @new_i) {
  	    my $i = @new_i ? $new_i[-1] + 2 : @new;
  	    my @splice = splice @vals, @new_i, @vals - @new_i;
  
  	    splice @new, $i, 0, map { $key => $_ } @splice;
  	}
  	if (@vals) {
  	    #print "SET $new_i[0]\n";
  	    @new[ map $_ + 1, @new_i ] = @vals;
  	}
  
  	$self->query_form(\@new);
      }
  
      return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef;
  }
  
  sub URI::_query::query_param_append {
      my $self = shift;
      my $key = shift;
      my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_;
      $self->query_form($self->query_form, $key => \@vals);  # XXX
      return;
  }
  
  sub URI::_query::query_param_delete {
      my $self = shift;
      my $key = shift;
      my @old = $self->query_form;
      my @vals;
  
      for (my $i = @old - 2; $i >= 0; $i -= 2) {
  	next if $old[$i] ne $key;
  	push(@vals, (splice(@old, $i, 2))[1]);
      }
      $self->query_form(\@old) if @vals;
      return wantarray ? reverse @vals : $vals[-1];
  }
  
  sub URI::_query::query_form_hash {
      my $self = shift;
      my @old = $self->query_form;
      if (@_) {
  	$self->query_form(@_ == 1 ? %{shift(@_)} : @_);
      }
      my %hash;
      while (my($k, $v) = splice(@old, 0, 2)) {
  	if (exists $hash{$k}) {
  	    for ($hash{$k}) {
  		$_ = [$_] unless ref($_) eq "ARRAY";
  		push(@$_, $v);
  	    }
  	}
  	else {
  	    $hash{$k} = $v;
  	}
      }
      return \%hash;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::QueryParam - Additional query methods for URIs
  
  =head1 SYNOPSIS
  
    use URI;
    use URI::QueryParam;
  
    $u = URI->new("", "http");
    $u->query_param(foo => 1, 2, 3);
    print $u->query;    # prints foo=1&foo=2&foo=3
  
    for my $key ($u->query_param) {
        print "$key: ", join(", ", $u->query_param($key)), "\n";
    }
  
  =head1 DESCRIPTION
  
  Loading the C<URI::QueryParam> module adds some extra methods to
  URIs that support query methods.  These methods provide an alternative
  interface to the $u->query_form data.
  
  The query_param_* methods have deliberately been made identical to the
  interface of the corresponding C<CGI.pm> methods.
  
  The following additional methods are made available:
  
  =over
  
  =item @keys = $u->query_param
  
  =item @values = $u->query_param( $key )
  
  =item $first_value = $u->query_param( $key )
  
  =item $u->query_param( $key, $value,... )
  
  If $u->query_param is called with no arguments, it returns all the
  distinct parameter keys of the URI.  In a scalar context it returns the
  number of distinct keys.
  
  When a $key argument is given, the method returns the parameter values with the
  given key.  In a scalar context, only the first parameter value is
  returned.
  
  If additional arguments are given, they are used to update successive
  parameters with the given key.  If any of the values provided are
  array references, then the array is dereferenced to get the actual
  values.
  
  Please note that you can supply multiple values to this method, but you cannot
  supply multiple keys.
  
  Do this:
  
      $uri->query_param( widget_id => 1, 5, 9 );
  
  Do NOT do this:
  
      $uri->query_param( widget_id => 1, frobnicator_id => 99 );
  
  =item $u->query_param_append($key, $value,...)
  
  Adds new parameters with the given
  key without touching any old parameters with the same key.  It
  can be explained as a more efficient version of:
  
     $u->query_param($key,
                     $u->query_param($key),
                     $value,...);
  
  One difference is that this expression would return the old values
  of $key, whereas the query_param_append() method does not.
  
  =item @values = $u->query_param_delete($key)
  
  =item $first_value = $u->query_param_delete($key)
  
  Deletes all key/value pairs with the given key.
  The old values are returned.  In a scalar context, only the first value
  is returned.
  
  Using the query_param_delete() method is slightly more efficient than
  the equivalent:
  
     $u->query_param($key, []);
  
  =item $hashref = $u->query_form_hash
  
  =item $u->query_form_hash( \%new_form )
  
  Returns a reference to a hash that represents the
  query form's key/value pairs.  If a key occurs multiple times, then the hash
  value becomes an array reference.
  
  Note that sequence information is lost.  This means that:
  
     $u->query_form_hash($u->query_form_hash);
  
  is not necessarily a no-op, as it may reorder the key/value pairs.
  The values returned by the query_param() method should stay the same
  though.
  
  =back
  
  =head1 SEE ALSO
  
  L<URI>, L<CGI>
  
  =head1 COPYRIGHT
  
  Copyright 2002 Gisle Aas.
  
  =cut
URI_QUERYPARAM

$fatpacked{"URI/Split.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SPLIT';
  package URI::Split;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use Exporter 5.57 'import';
  our @EXPORT_OK = qw(uri_split uri_join);
  
  use URI::Escape ();
  
  sub uri_split {
       return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
  }
  
  sub uri_join {
      my($scheme, $auth, $path, $query, $frag) = @_;
      my $uri = defined($scheme) ? "$scheme:" : "";
      $path = "" unless defined $path;
      if (defined $auth) {
  	$auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
  	$uri .= "//$auth";
  	$path = "/$path" if length($path) && $path !~ m,^/,;
      }
      elsif ($path =~ m,^//,) {
  	$uri .= "//";  # XXX force empty auth
      }
      unless (length $uri) {
  	$path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,;
      }
      $path =~ s,([?\#]), URI::Escape::escape_char($1),eg;
      $uri .= $path;
      if (defined $query) {
  	$query =~ s,(\#), URI::Escape::escape_char($1),eg;
  	$uri .= "?$query";
      }
      $uri .= "#$frag" if defined $frag;
      $uri;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::Split - Parse and compose URI strings
  
  =head1 SYNOPSIS
  
   use URI::Split qw(uri_split uri_join);
   ($scheme, $auth, $path, $query, $frag) = uri_split($uri);
   $uri = uri_join($scheme, $auth, $path, $query, $frag);
  
  =head1 DESCRIPTION
  
  Provides functions to parse and compose URI
  strings.  The following functions are provided:
  
  =over
  
  =item ($scheme, $auth, $path, $query, $frag) = uri_split($uri)
  
  Breaks up a URI string into its component
  parts.  An C<undef> value is returned for those parts that are not
  present.  The $path part is always present (but can be the empty
  string) and is thus never returned as C<undef>.
  
  No sensible value is returned if this function is called in a scalar
  context.
  
  =item $uri = uri_join($scheme, $auth, $path, $query, $frag)
  
  Puts together a URI string from its parts.
  Missing parts are signaled by passing C<undef> for the corresponding
  argument.
  
  Minimal escaping is applied to parts that contain reserved chars
  that would confuse a parser.  For instance, any occurrence of '?' or '#'
  in $path is always escaped, as it would otherwise be parsed back
  as a query or fragment.
  
  =back
  
  =head1 SEE ALSO
  
  L<URI>, L<URI::Escape>
  
  =head1 COPYRIGHT
  
  Copyright 2003, Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
URI_SPLIT

$fatpacked{"URI/URL.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URL';
  package URI::URL;
  
  use strict;
  use warnings;
  
  use parent 'URI::WithBase';
  
  our $VERSION = "5.04";
  
  # Provide as much as possible of the old URI::URL interface for backwards
  # compatibility...
  
  use Exporter 5.57 'import';
  our @EXPORT = qw(url);
  
  # Easy to use constructor
  sub url ($;$) { URI::URL->new(@_); }
  
  use URI::Escape qw(uri_unescape);
  
  sub new
  {
      my $class = shift;
      my $self = $class->SUPER::new(@_);
      $self->[0] = $self->[0]->canonical;
      $self;
  }
  
  sub newlocal
  {
      my $class = shift;
      require URI::file;
      bless [URI::file->new_abs(shift)], $class;
  }
  
  {package URI::_foreign;
      sub _init  # hope it is not defined
      {
  	my $class = shift;
  	die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT;
  	$class->SUPER::_init(@_);
      }
  }
  
  sub strict
  {
      my $old = $URI::URL::STRICT;
      $URI::URL::STRICT = shift if @_;
      $old;
  }
  
  sub print_on
  {
      my $self = shift;
      require Data::Dumper;
      print STDERR Data::Dumper::Dumper($self);
  }
  
  sub _try
  {
      my $self = shift;
      my $method = shift;
      scalar(eval { $self->$method(@_) });
  }
  
  sub crack
  {
      # should be overridden by subclasses
      my $self = shift;
      (scalar($self->scheme),
       $self->_try("user"),
       $self->_try("password"),
       $self->_try("host"),
       $self->_try("port"),
       $self->_try("path"),
       $self->_try("params"),
       $self->_try("query"),
       scalar($self->fragment),
      )
  }
  
  sub full_path
  {
      my $self = shift;
      my $path = $self->path_query;
      $path = "/" unless length $path;
      $path;
  }
  
  sub netloc
  {
      shift->authority(@_);
  }
  
  sub epath
  {
      my $path = shift->SUPER::path(@_);
      $path =~ s/;.*//;
      $path;
  }
  
  sub eparams
  {
      my $self = shift;
      my @p = $self->path_segments;
      return undef unless ref($p[-1]);
      @p = @{$p[-1]};
      shift @p;
      join(";", @p);
  }
  
  sub params { shift->eparams(@_); }
  
  sub path {
      my $self = shift;
      my $old = $self->epath(@_);
      return unless defined wantarray;
      return '/' if !defined($old) || !length($old);
      Carp::croak("Path components contain '/' (you must call epath)")
  	if $old =~ /%2[fF]/ and !@_;
      $old = "/$old" if $old !~ m|^/| && defined $self->netloc;
      return uri_unescape($old);
  }
  
  sub path_components {
      shift->path_segments(@_);
  }
  
  sub query {
      my $self = shift;
      my $old = $self->equery(@_);
      if (defined(wantarray) && defined($old)) {
  	if ($old =~ /%(?:26|2[bB]|3[dD])/) {  # contains escaped '=' '&' or '+'
  	    my $mess;
  	    for ($old) {
  		$mess = "Query contains both '+' and '%2B'"
  		  if /\+/ && /%2[bB]/;
  		$mess = "Form query contains escaped '=' or '&'"
  		  if /=/  && /%(?:3[dD]|26)/;
  	    }
  	    if ($mess) {
  		Carp::croak("$mess (you must call equery)");
  	    }
  	}
  	# Now it should be safe to unescape the string without losing
  	# information
  	return uri_unescape($old);
      }
      undef;
  
  }
  
  sub abs
  {
      my $self = shift;
      my $base = shift;
      my $allow_scheme = shift;
      $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME
  	unless defined $allow_scheme;
      local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme;
      local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS;
      $self->SUPER::abs($base);
  }
  
  sub frag { shift->fragment(@_); }
  sub keywords { shift->query_keywords(@_); }
  
  # file:
  sub local_path { shift->file; }
  sub unix_path  { shift->file("unix"); }
  sub dos_path   { shift->file("dos");  }
  sub mac_path   { shift->file("mac");  }
  sub vms_path   { shift->file("vms");  }
  
  # mailto:
  sub address { shift->to(@_); }
  sub encoded822addr { shift->to(@_); }
  sub URI::mailto::authority { shift->to(@_); }  # make 'netloc' method work
  
  # news:
  sub groupart { shift->_group(@_); }
  sub article  { shift->message(@_); }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::URL - Uniform Resource Locators
  
  =head1 SYNOPSIS
  
   $u1 = URI::URL->new($str, $base);
   $u2 = $u1->abs;
  
  =head1 DESCRIPTION
  
  This module is provided for backwards compatibility with modules that
  depend on the interface provided by the C<URI::URL> class that used to
  be distributed with the libwww-perl library.
  
  The following differences exist compared to the C<URI> class interface:
  
  =over 3
  
  =item *
  
  The URI::URL module exports the url() function as an alternate
  constructor interface.
  
  =item *
  
  The constructor takes an optional $base argument.  The C<URI::URL>
  class is a subclass of C<URI::WithBase>.
  
  =item *
  
  The URI::URL->newlocal class method is the same as URI::file->new_abs.
  
  =item *
  
  URI::URL::strict(1)
  
  =item *
  
  $url->print_on method
  
  =item *
  
  $url->crack method
  
  =item *
  
  $url->full_path: same as ($uri->abs_path || "/")
  
  =item *
  
  $url->netloc: same as $uri->authority
  
  =item *
  
  $url->epath, $url->equery: same as $uri->path, $uri->query
  
  =item *
  
  $url->path and $url->query pass unescaped strings.
  
  =item *
  
  $url->path_components: same as $uri->path_segments (if you don't
  consider path segment parameters)
  
  =item *
  
  $url->params and $url->eparams methods
  
  =item *
  
  $url->base method.  See L<URI::WithBase>.
  
  =item *
  
  $url->abs and $url->rel have an optional $base argument.  See
  L<URI::WithBase>.
  
  =item *
  
  $url->frag: same as $uri->fragment
  
  =item *
  
  $url->keywords: same as $uri->query_keywords
  
  =item *
  
  $url->localpath and friends map to $uri->file.
  
  =item *
  
  $url->address and $url->encoded822addr: same as $uri->to for mailto URI
  
  =item *
  
  $url->groupart method for news URI
  
  =item *
  
  $url->article: same as $uri->message
  
  =back
  
  
  
  =head1 SEE ALSO
  
  L<URI>, L<URI::WithBase>
  
  =head1 COPYRIGHT
  
  Copyright 1998-2000 Gisle Aas.
  
  =cut
URI_URL

$fatpacked{"URI/WithBase.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_WITHBASE';
  package URI::WithBase;
  
  use strict;
  use warnings;
  
  use URI;
  use Scalar::Util 'blessed';
  
  our $VERSION = "2.20";
  
  use overload '""' => "as_string", fallback => 1;
  
  sub as_string;  # help overload find it
  
  sub new
  {
      my($class, $uri, $base) = @_;
      my $ibase = $base;
      if ($base && blessed($base) && $base->isa(__PACKAGE__)) {
  	$base = $base->abs;
  	$ibase = $base->[0];
      }
      bless [URI->new($uri, $ibase), $base], $class;
  }
  
  sub new_abs
  {
      my $class = shift;
      my $self = $class->new(@_);
      $self->abs;
  }
  
  sub _init
  {
      my $class = shift;
      my($str, $scheme) = @_;
      bless [URI->new($str, $scheme), undef], $class;
  }
  
  sub eq
  {
      my($self, $other) = @_;
      $other = $other->[0] if blessed($other) and $other->isa(__PACKAGE__);
      $self->[0]->eq($other);
  }
  
  our $AUTOLOAD;
  sub AUTOLOAD
  {
      my $self = shift;
      my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
      return if $method eq "DESTROY";
      $self->[0]->$method(@_);
  }
  
  sub can {                                  # override UNIVERSAL::can
      my $self = shift;
      $self->SUPER::can(@_) || (
        ref($self)
        ? $self->[0]->can(@_)
        : undef
      )
  }
  
  sub base {
      my $self = shift;
      my $base  = $self->[1];
  
      if (@_) { # set
  	my $new_base = shift;
  	# ensure absoluteness
  	$new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__);
  	$self->[1] = $new_base;
      }
      return unless defined wantarray;
  
      # The base attribute supports 'lazy' conversion from URL strings
      # to URL objects. Strings may be stored but when a string is
      # fetched it will automatically be converted to a URL object.
      # The main benefit is to make it much cheaper to say:
      #   URI::WithBase->new($random_url_string, 'http:')
      if (defined($base) && !ref($base)) {
  	$base = ref($self)->new($base);
  	$self->[1] = $base unless @_;
      }
      $base;
  }
  
  sub clone
  {
      my $self = shift;
      my $base = $self->[1];
      $base = $base->clone if ref($base);
      bless [$self->[0]->clone, $base], ref($self);
  }
  
  sub abs
  {
      my $self = shift;
      my $base = shift || $self->base || return $self->clone;
      $base = $base->as_string if ref($base);
      bless [$self->[0]->abs($base, @_), $base], ref($self);
  }
  
  sub rel
  {
      my $self = shift;
      my $base = shift || $self->base || return $self->clone;
      $base = $base->as_string if ref($base);
      bless [$self->[0]->rel($base, @_), $base], ref($self);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::WithBase - URIs which remember their base
  
  =head1 SYNOPSIS
  
   $u1 = URI::WithBase->new($str, $base);
   $u2 = $u1->abs;
  
   $base = $u1->base;
   $u1->base( $new_base )
  
  =head1 DESCRIPTION
  
  This module provides the C<URI::WithBase> class.  Objects of this class
  are like C<URI> objects, but can keep their base too.  The base
  represents the context where this URI was found and can be used to
  absolutize or relativize the URI.  All the methods described in L<URI>
  are supported for C<URI::WithBase> objects.
  
  The methods provided in addition to or modified from those of C<URI> are:
  
  =over 4
  
  =item $uri = URI::WithBase->new($str, [$base])
  
  The constructor takes an optional base URI as the second argument.
  If provided, this argument initializes the base attribute.
  
  =item $uri->base( [$new_base] )
  
  Can be used to get or set the value of the base attribute.
  The return value, which is the old value, is a URI object or C<undef>.
  
  =item $uri->abs( [$base_uri] )
  
  The $base_uri argument is now made optional as the object carries its
  base with it.  A new object is returned even if $uri is already
  absolute (while plain URI objects simply return themselves in
  that case).
  
  =item $uri->rel( [$base_uri] )
  
  The $base_uri argument is now made optional as the object carries its
  base with it.  A new object is always returned.
  
  =back
  
  
  =head1 SEE ALSO
  
  L<URI>
  
  =head1 COPYRIGHT
  
  Copyright 1998-2002 Gisle Aas.
  
  =cut
URI_WITHBASE

$fatpacked{"URI/_foreign.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__FOREIGN';
  package URI::_foreign;
  
  use strict;
  use warnings;
  
  use parent 'URI::_generic';
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  1;
URI__FOREIGN

$fatpacked{"URI/_generic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__GENERIC';
  package URI::_generic;
  
  use strict;
  use warnings;
  
  use parent qw(URI URI::_query);
  
  use URI::Escape qw(uri_unescape);
  use Carp ();
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  my $ACHAR = $URI::uric;  $ACHAR =~ s,\\[/?],,g;
  my $PCHAR = $URI::uric;  $PCHAR =~ s,\\[?],,g;
  
  sub _no_scheme_ok { 1 }
  
  sub authority
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
  
      if (@_) {
  	my $auth = shift;
  	$$self = $1;
  	my $rest = $3;
  	if (defined $auth) {
  	    $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
  	    utf8::downgrade($auth);
  	    $$self .= "//$auth";
  	}
  	_check_path($rest, $$self);
  	$$self .= $rest;
      }
      $2;
  }
  
  sub path
  {
      my $self = shift;
      $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
  
      if (@_) {
  	$$self = $1;
  	my $rest = $3;
  	my $new_path = shift;
  	$new_path = "" unless defined $new_path;
  	$new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
  	utf8::downgrade($new_path);
  	_check_path($new_path, $$self);
  	$$self .= $new_path . $rest;
      }
      $2;
  }
  
  sub path_query
  {
      my $self = shift;
      $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
  
      if (@_) {
  	$$self = $1;
  	my $rest = $3;
  	my $new_path = shift;
  	$new_path = "" unless defined $new_path;
  	$new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
  	utf8::downgrade($new_path);
  	_check_path($new_path, $$self);
  	$$self .= $new_path . $rest;
      }
      $2;
  }
  
  sub _check_path
  {
      my($path, $pre) = @_;
      my $prefix;
      if ($pre =~ m,/,) {  # authority present
  	$prefix = "/" if length($path) && $path !~ m,^[/?\#],;
      }
      else {
  	if ($path =~ m,^//,) {
  	    Carp::carp("Path starting with double slash is confusing")
  		if $^W;
  	}
  	elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
  	    Carp::carp("Path might look like scheme, './' prepended")
  		if $^W;
  	    $prefix = "./";
  	}
      }
      substr($_[0], 0, 0) = $prefix if defined $prefix;
  }
  
  sub path_segments
  {
      my $self = shift;
      my $path = $self->path;
      if (@_) {
  	my @arg = @_;  # make a copy
  	for (@arg) {
  	    if (ref($_)) {
  		my @seg = @$_;
  		$seg[0] =~ s/%/%25/g;
  		for (@seg) { s/;/%3B/g; }
  		$_ = join(";", @seg);
  	    }
  	    else {
  		 s/%/%25/g; s/;/%3B/g;
  	    }
  	    s,/,%2F,g;
  	}
  	$self->path(join("/", @arg));
      }
      return $path unless wantarray;
      map {/;/ ? $self->_split_segment($_)
               : uri_unescape($_) }
          split('/', $path, -1);
  }
  
  
  sub _split_segment
  {
      my $self = shift;
      require URI::_segment;
      URI::_segment->new(@_);
  }
  
  
  sub abs
  {
      my $self = shift;
      my $base = shift || Carp::croak("Missing base argument");
  
      if (my $scheme = $self->scheme) {
  	return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
  	$base = URI->new($base) unless ref $base;
  	return $self unless $scheme eq $base->scheme;
      }
  
      $base = URI->new($base) unless ref $base;
      my $abs = $self->clone;
      $abs->scheme($base->scheme);
      return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
      $abs->authority($base->authority);
  
      my $path = $self->path;
      return $abs if $path =~ m,^/,;
  
      if (!length($path)) {
  	my $abs = $base->clone;
  	my $query = $self->query;
  	$abs->query($query) if defined $query;
  	my $fragment = $self->fragment;
  	$abs->fragment($fragment) if defined $fragment;
  	return $abs;
      }
  
      my $p = $base->path;
      $p =~ s,[^/]+$,,;
      $p .= $path;
      my @p = split('/', $p, -1);
      shift(@p) if @p && !length($p[0]);
      my $i = 1;
      while ($i < @p) {
  	#print "$i ", join("/", @p), " ($p[$i])\n";
  	if ($p[$i-1] eq ".") {
  	    splice(@p, $i-1, 1);
  	    $i-- if $i > 1;
  	}
  	elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
  	    splice(@p, $i-1, 2);
  	    if ($i > 1) {
  		$i--;
  		push(@p, "") if $i == @p;
  	    }
  	}
  	else {
  	    $i++;
  	}
      }
      $p[-1] = "" if @p && $p[-1] eq ".";  # trailing "/."
      if ($URI::ABS_REMOTE_LEADING_DOTS) {
          shift @p while @p && $p[0] =~ /^\.\.?$/;
      }
      $abs->path("/" . join("/", @p));
      $abs;
  }
  
  # The opposite of $url->abs.  Return a URI which is as relative as possible
  sub rel {
      my $self = shift;
      my $base = shift || Carp::croak("Missing base argument");
      my $rel = $self->clone;
      $base = URI->new($base) unless ref $base;
  
      #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
      my $scheme = $rel->scheme;
      my $auth   = $rel->canonical->authority;
      my $path   = $rel->path;
  
      if (!defined($scheme) && !defined($auth)) {
  	# it is already relative
  	return $rel;
      }
  
      #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
      my $bscheme = $base->scheme;
      my $bauth   = $base->canonical->authority;
      my $bpath   = $base->path;
  
      for ($bscheme, $bauth, $auth) {
  	$_ = '' unless defined
      }
  
      unless ($scheme eq $bscheme && $auth eq $bauth) {
  	# different location, can't make it relative
  	return $rel;
      }
  
      for ($path, $bpath) {  $_ = "/$_" unless m,^/,; }
  
      # Make it relative by eliminating scheme and authority
      $rel->scheme(undef);
      $rel->authority(undef);
  
      # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
      # First we calculate common initial path components length ($li).
      my $li = 1;
      while (1) {
  	my $i = index($path, '/', $li);
  	last if $i < 0 ||
                  $i != index($bpath, '/', $li) ||
  	        substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
  	$li=$i+1;
      }
      # then we nuke it from both paths
      substr($path, 0,$li) = '';
      substr($bpath,0,$li) = '';
  
      if ($path eq $bpath &&
          defined($rel->fragment) &&
          !defined($rel->query)) {
          $rel->path("");
      }
      else {
          # Add one "../" for each path component left in the base path
          $path = ('../' x $bpath =~ tr|/|/|) . $path;
  	$path = "./" if $path eq "";
          $rel->path($path);
      }
  
      $rel;
  }
  
  1;
URI__GENERIC

$fatpacked{"URI/_idna.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__IDNA';
  package URI::_idna;
  
  # This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep)
  # based on Python-2.6.4/Lib/encodings/idna.py
  
  use strict;
  use warnings;
  
  use URI::_punycode qw(encode_punycode decode_punycode);
  use Carp qw(croak);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  BEGIN {
    *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = "$]" < 5.008_003
      ? sub () { 1 }
      : sub () { 0 }
    ;
  }
  
  my $ASCII = qr/^[\x00-\x7F]*\z/;
  
  sub encode {
      my $idomain = shift;
      my @labels = split(/\./, $idomain, -1);
      my @last_empty;
      push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq "";
      for (@labels) {
  	$_ = ToASCII($_);
      }
  
      return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS;
      return join(".", @labels, @last_empty);
  }
  
  sub decode {
      my $domain = shift;
      return join(".", map ToUnicode($_), split(/\./, $domain, -1))
  }
  
  sub nameprep { # XXX real implementation missing
      my $label = shift;
      $label = lc($label);
      return $label;
  }
  
  sub check_size {
      my $label = shift;
      croak "Label empty" if $label eq "";
      croak "Label too long" if length($label) > 63;
      return $label;
  }
  
  sub ToASCII {
      my $label = shift;
      return check_size($label) if $label =~ $ASCII;
  
      # Step 2: nameprep
      $label = nameprep($label);
      # Step 3: UseSTD3ASCIIRules is false
      # Step 4: try ASCII again
      return check_size($label) if $label =~ $ASCII;
  
      # Step 5: Check ACE prefix
      if ($label =~ /^xn--/) {
          croak "Label starts with ACE prefix";
      }
  
      # Step 6: Encode with PUNYCODE
      $label = encode_punycode($label);
  
      # Step 7: Prepend ACE prefix
      $label = "xn--$label";
  
      # Step 8: Check size
      return check_size($label);
  }
  
  sub ToUnicode {
      my $label = shift;
      $label = nameprep($label) unless $label =~ $ASCII;
      return $label unless $label =~ /^xn--/;
      my $result = decode_punycode(substr($label, 4));
      my $label2 = ToASCII($result);
      if (lc($label) ne $label2) {
  	croak "IDNA does not round-trip: '\L$label\E' vs '$label2'";
      }
      return $result;
  }
  
  1;
URI__IDNA

$fatpacked{"URI/_ldap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__LDAP';
  # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
  # This program is free software; you can redistribute it and/or
  # modify it under the same terms as Perl itself.
  
  package URI::_ldap;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use URI::Escape qw(uri_unescape);
  
  sub _ldap_elem {
    my $self  = shift;
    my $elem  = shift;
    my $query = $self->query;
    my @bits  = (split(/\?/,defined($query) ? $query : ""),("")x4);
    my $old   = $bits[$elem];
  
    if (@_) {
      my $new = shift;
      $new =~ s/\?/%3F/g;
      $bits[$elem] = $new;
      $query = join("?",@bits);
      $query =~ s/\?+$//;
      $query = undef unless length($query);
      $self->query($query);
    }
  
    $old;
  }
  
  sub dn {
    my $old = shift->path(@_);
    $old =~ s:^/::;
    uri_unescape($old);
  }
  
  sub attributes {
    my $self = shift;
    my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
    return $old unless wantarray;
    map { uri_unescape($_) } split(/,/,$old);
  }
  
  sub _scope {
    my $self = shift;
    my $old = _ldap_elem($self,1, @_);
    return undef unless defined wantarray && defined $old;
    uri_unescape($old);
  }
  
  sub scope {
    my $old = &_scope;
    $old = "base" unless length $old;
    $old;
  }
  
  sub _filter {
    my $self = shift;
    my $old = _ldap_elem($self,2, @_);
    return undef unless defined wantarray && defined $old;
    uri_unescape($old); # || "(objectClass=*)";
  }
  
  sub filter {
    my $old = &_filter;
    $old = "(objectClass=*)" unless length $old;
    $old;
  }
  
  sub extensions {
    my $self = shift;
    my @ext;
    while (@_) {
      my $key = shift;
      my $value = shift;
      push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
    }
    @ext = join(",", @ext) if @ext;
    my $old = _ldap_elem($self,3, @ext);
    return $old unless wantarray;
    map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
  }
  
  sub canonical
  {
      my $self = shift;
      my $other = $self->_nonldap_canonical;
  
      # The stuff below is not as efficient as one might hope...
  
      $other = $other->clone if $other == $self;
  
      $other->dn(_normalize_dn($other->dn));
  
      # Should really know about mixed case "postalAddress", etc...
      $other->attributes(map lc, $other->attributes);
  
      # Lowercase scope, remove default
      my $old_scope = $other->scope;
      my $new_scope = lc($old_scope);
      $new_scope = "" if $new_scope eq "base";
      $other->scope($new_scope) if $new_scope ne $old_scope;
  
      # Remove filter if default
      my $old_filter = $other->filter;
      $other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
  	                  lc($old_filter) eq "objectclass=*";
  
      # Lowercase extensions types and deal with known extension values
      my @ext = $other->extensions;
      for (my $i = 0; $i < @ext; $i += 2) {
  	my $etype = $ext[$i] = lc($ext[$i]);
  	if ($etype =~ /^!?bindname$/) {
  	    $ext[$i+1] = _normalize_dn($ext[$i+1]);
  	}
      }
      $other->extensions(@ext) if @ext;
      
      $other;
  }
  
  sub _normalize_dn  # RFC 2253
  {
      my $dn = shift;
  
      return $dn;
      # The code below will fail if the "+" or "," is embedding in a quoted
      # string or simply escaped...
  
      my @dn = split(/([+,])/, $dn);
      for (@dn) {
  	s/^([a-zA-Z]+=)/lc($1)/e;
      }
      join("", @dn);
  }
  
  1;
URI__LDAP

$fatpacked{"URI/_login.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__LOGIN';
  package URI::_login;
  
  use strict;
  use warnings;
  
  use parent qw(URI::_server URI::_userpass);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  # Generic terminal logins.  This is used as a base class for 'telnet',
  # 'tn3270', and 'rlogin' URL schemes.
  
  1;
URI__LOGIN

$fatpacked{"URI/_punycode.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__PUNYCODE';
  package URI::_punycode;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use Exporter 'import';
  our @EXPORT = qw(encode_punycode decode_punycode);
  
  use integer;
  
  our $DEBUG = 0;
  
  use constant BASE => 36;
  use constant TMIN => 1;
  use constant TMAX => 26;
  use constant SKEW => 38;
  use constant DAMP => 700;
  use constant INITIAL_BIAS => 72;
  use constant INITIAL_N => 128;
  
  my $Delimiter = chr 0x2D;
  my $BasicRE   = qr/[\x00-\x7f]/;
  
  sub _croak { require Carp; Carp::croak(@_); }
  
  sub digit_value {
      my $code = shift;
      return ord($code) - ord("A") if $code =~ /[A-Z]/;
      return ord($code) - ord("a") if $code =~ /[a-z]/;
      return ord($code) - ord("0") + 26 if $code =~ /[0-9]/;
      return;
  }
  
  sub code_point {
      my $digit = shift;
      return $digit + ord('a') if 0 <= $digit && $digit <= 25;
      return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36;
      die 'NOT COME HERE';
  }
  
  sub adapt {
      my($delta, $numpoints, $firsttime) = @_;
      $delta = $firsttime ? $delta / DAMP : $delta / 2;
      $delta += $delta / $numpoints;
      my $k = 0;
      while ($delta > ((BASE - TMIN) * TMAX) / 2) {
  	$delta /= BASE - TMIN;
  	$k += BASE;
      }
      return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW));
  }
  
  sub decode_punycode {
      my $code = shift;
  
      my $n      = INITIAL_N;
      my $i      = 0;
      my $bias   = INITIAL_BIAS;
      my @output;
  
      if ($code =~ s/(.*)$Delimiter//o) {
  	push @output, map ord, split //, $1;
  	return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o;
      }
  
      while ($code) {
  	my $oldi = $i;
  	my $w    = 1;
      LOOP:
  	for (my $k = BASE; 1; $k += BASE) {
  	    my $cp = substr($code, 0, 1, '');
  	    my $digit = digit_value($cp);
  	    defined $digit or return _croak("invalid punycode input");
  	    $i += $digit * $w;
  	    my $t = ($k <= $bias) ? TMIN
  		: ($k >= $bias + TMAX) ? TMAX : $k - $bias;
  	    last LOOP if $digit < $t;
  	    $w *= (BASE - $t);
  	}
  	$bias = adapt($i - $oldi, @output + 1, $oldi == 0);
  	warn "bias becomes $bias" if $DEBUG;
  	$n += $i / (@output + 1);
  	$i = $i % (@output + 1);
  	splice(@output, $i, 0, $n);
  	warn join " ", map sprintf('%04x', $_), @output if $DEBUG;
  	$i++;
      }
      return join '', map chr, @output;
  }
  
  sub encode_punycode {
      my $input = shift;
      my @input = split //, $input;
  
      my $n     = INITIAL_N;
      my $delta = 0;
      my $bias  = INITIAL_BIAS;
  
      my @output;
      my @basic = grep /$BasicRE/, @input;
      my $h = my $b = @basic;
      push @output, @basic;
      push @output, $Delimiter if $b && $h < @input;
      warn "basic codepoints: (@output)" if $DEBUG;
  
      while ($h < @input) {
  	my $m = min(grep { $_ >= $n } map ord, @input);
  	warn sprintf "next code point to insert is %04x", $m if $DEBUG;
  	$delta += ($m - $n) * ($h + 1);
  	$n = $m;
  	for my $i (@input) {
  	    my $c = ord($i);
  	    $delta++ if $c < $n;
  	    if ($c == $n) {
  		my $q = $delta;
  	    LOOP:
  		for (my $k = BASE; 1; $k += BASE) {
  		    my $t = ($k <= $bias) ? TMIN :
  			($k >= $bias + TMAX) ? TMAX : $k - $bias;
  		    last LOOP if $q < $t;
  		    my $cp = code_point($t + (($q - $t) % (BASE - $t)));
  		    push @output, chr($cp);
  		    $q = ($q - $t) / (BASE - $t);
  		}
  		push @output, chr(code_point($q));
  		$bias = adapt($delta, $h + 1, $h == $b);
  		warn "bias becomes $bias" if $DEBUG;
  		$delta = 0;
  		$h++;
  	    }
  	}
  	$delta++;
  	$n++;
      }
      return join '', @output;
  }
  
  sub min {
      my $min = shift;
      for (@_) { $min = $_ if $_ <= $min }
      return $min;
  }
  
  1;
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  URI::_punycode - encodes Unicode string in Punycode
  
  =head1 SYNOPSIS
  
    use strict;
    use warnings;
    use utf8;
  
    use URI::_punycode qw(encode_punycode decode_punycode);
  
    # encode a unicode string
    my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
    $punycode = encode_punycode('bücher'); # bcher-kva
    $punycode = encode_punycode('他们为什么不说中文'); # ihqwcrb4cv8a8dqg056pqjye
  
    # decode a punycode string back into a unicode string
    my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
    $unicode = decode_punycode('bcher-kva'); # bücher
    $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
  
  =head1 DESCRIPTION
  
  L<URI::_punycode> is a module to encode / decode Unicode strings into
  L<Punycode|https://tools.ietf.org/html/rfc3492>, an efficient
  encoding of Unicode for use with L<IDNA|https://tools.ietf.org/html/rfc5890>.
  
  =head1 FUNCTIONS
  
  All functions throw exceptions on failure. You can C<catch> them with
  L<Syntax::Keyword::Try> or L<Try::Tiny>. The following functions are exported
  by default.
  
  =head2 encode_punycode
  
    my $punycode = encode_punycode('http://☃.net');  # http://.net-xc8g
    $punycode = encode_punycode('bücher'); # bcher-kva
    $punycode = encode_punycode('他们为什么不说中文') # ihqwcrb4cv8a8dqg056pqjye
  
  Takes a Unicode string (UTF8-flagged variable) and returns a Punycode
  encoding for it.
  
  =head2 decode_punycode
  
    my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
    $unicode = decode_punycode('bcher-kva'); # bücher
    $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
  
  Takes a Punycode encoding and returns original Unicode string.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa <F<miyagawa@bulknews.net>> is the author of
  L<IDNA::Punycode> which was the basis for this module.
  
  =head1 SEE ALSO
  
  L<IDNA::Punycode>, L<RFC 3492|https://tools.ietf.org/html/rfc3492>,
  L<RFC 5891|https://tools.ietf.org/html/rfc5891>
  
  =head1 COPYRIGHT AND LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
URI__PUNYCODE

$fatpacked{"URI/_query.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__QUERY';
  package URI::_query;
  
  use strict;
  use warnings;
  
  use URI ();
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub query
  {
      my $self = shift;
      $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die;
  
      if (@_) {
  	my $q = shift;
  	$$self = $1;
  	if (defined $q) {
  	    $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
  	    utf8::downgrade($q);
  	    $$self .= "?$q";
  	}
  	$$self .= $3;
      }
      $2;
  }
  
  # Handle ...?foo=bar&bar=foo type of query
  sub query_form {
      my $self = shift;
      my $old = $self->query;
      if (@_) {
          # Try to set query string
          my $delim;
          my $r = $_[0];
          if (ref($r) eq "ARRAY") {
              $delim = $_[1];
              @_ = @$r;
          }
          elsif (ref($r) eq "HASH") {
              $delim = $_[1];
              @_ = map { $_ => $r->{$_} } sort keys %$r;
          }
          $delim = pop if @_ % 2;
  
          my @query;
          while (my($key,$vals) = splice(@_, 0, 2)) {
              $key = '' unless defined $key;
  	    $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
  	    $key =~ s/ /+/g;
  	    $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
              for my $val (@$vals) {
                  $val = '' unless defined $val;
  		$val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
                  $val =~ s/ /+/g;
                  push(@query, "$key=$val");
              }
          }
          if (@query) {
              unless ($delim) {
                  $delim = $1 if $old && $old =~ /([&;])/;
                  $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&";
              }
              $self->query(join($delim, @query));
          }
          else {
              $self->query(undef);
          }
      }
      return if !defined($old) || !length($old) || !defined(wantarray);
      return unless $old =~ /=/; # not a form
      map { s/\+/ /g; uri_unescape($_) }
           map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
  }
  
  # Handle ...?dog+bones type of query
  sub query_keywords
  {
      my $self = shift;
      my $old = $self->query;
      if (@_) {
          # Try to set query string
  	my @copy = @_;
  	@copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY";
  	for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
  	$self->query(@copy ? join('+', @copy) : undef);
      }
      return if !defined($old) || !defined(wantarray);
      return if $old =~ /=/;  # not keywords, but a form
      map { uri_unescape($_) } split(/\+/, $old, -1);
  }
  
  # Some URI::URL compatibility stuff
  sub equery { goto &query }
  
  1;
URI__QUERY

$fatpacked{"URI/_segment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__SEGMENT';
  package URI::_segment;
  
  # Represents a generic path_segment so that it can be treated as
  # a string too.
  
  use strict;
  use warnings;
  
  use URI::Escape qw(uri_unescape);
  
  use overload '""' => sub { $_[0]->[0] },
               fallback => 1;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub new
  {
      my $class = shift;
      my @segment = split(';', shift, -1);
      $segment[0] = uri_unescape($segment[0]);
      bless \@segment, $class;
  }
  
  1;
URI__SEGMENT

$fatpacked{"URI/_server.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__SERVER';
  package URI::_server;
  
  use strict;
  use warnings;
  
  use parent 'URI::_generic';
  
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub _uric_escape {
      my($class, $str) = @_;
      if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
  	my($scheme, $host, $rest) = ($1, $2, $3);
  	my $ui = $host =~ s/(.*@)// ? $1 : "";
  	my $port = $host =~ s/(:\d+)\z// ? $1 : "";
  	if (_host_escape($host)) {
  	    $str = "$scheme//$ui$host$port$rest";
  	}
      }
      return $class->SUPER::_uric_escape($str);
  }
  
  sub _host_escape {
      return unless $_[0] =~ /[^$URI::uric]/;
      eval {
  	require URI::_idna;
  	$_[0] = URI::_idna::encode($_[0]);
      };
      return 0 if $@;
      return 1;
  }
  
  sub as_iri {
      my $self = shift;
      my $str = $self->SUPER::as_iri;
      if ($str =~ /\bxn--/) {
  	if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
  	    my($scheme, $host, $rest) = ($1, $2, $3);
  	    my $ui = $host =~ s/(.*@)// ? $1 : "";
  	    my $port = $host =~ s/(:\d+)\z// ? $1 : "";
  	    require URI::_idna;
  	    $host = URI::_idna::decode($host);
  	    $str = "$scheme//$ui$host$port$rest";
  	}
      }
      return $str;
  }
  
  sub userinfo
  {
      my $self = shift;
      my $old = $self->authority;
  
      if (@_) {
  	my $new = $old;
  	$new = "" unless defined $new;
  	$new =~ s/.*@//;  # remove old stuff
  	my $ui = shift;
  	if (defined $ui) {
  	    $ui =~ s/@/%40/g;   # protect @
  	    $new = "$ui\@$new";
  	}
  	$self->authority($new);
      }
      return undef if !defined($old) || $old !~ /(.*)@/;
      return $1;
  }
  
  sub host
  {
      my $self = shift;
      my $old = $self->authority;
      if (@_) {
  	my $tmp = $old;
  	$tmp = "" unless defined $tmp;
  	my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
  	my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
  	my $new = shift;
  	$new = "" unless defined $new;
  	if (length $new) {
  	    $new =~ s/[@]/%40/g;   # protect @
  	    if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
  		$new =~ s/(:\d*)\z// || die "Assert";
  		$port = $1;
  	    }
  	    $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
  	    _host_escape($new);
  	}
  	$self->authority("$ui$new$port");
      }
      return undef unless defined $old;
      $old =~ s/.*@//;
      $old =~ s/:\d+$//;          # remove the port
      $old =~ s{^\[(.*)\]$}{$1};  # remove brackets around IPv6 (RFC 3986 3.2.2)
      return uri_unescape($old);
  }
  
  sub ihost
  {
      my $self = shift;
      my $old = $self->host(@_);
      if ($old =~ /(^|\.)xn--/) {
  	require URI::_idna;
  	$old = URI::_idna::decode($old);
      }
      return $old;
  }
  
  sub _port
  {
      my $self = shift;
      my $old = $self->authority;
      if (@_) {
  	my $new = $old;
  	$new =~ s/:\d*$//;
  	my $port = shift;
  	$new .= ":$port" if defined $port;
  	$self->authority($new);
      }
      return $1 if defined($old) && $old =~ /:(\d*)$/;
      return;
  }
  
  sub port
  {
      my $self = shift;
      my $port = $self->_port(@_);
      $port = $self->default_port if !defined($port) || $port eq "";
      $port;
  }
  
  sub host_port
  {
      my $self = shift;
      my $old = $self->authority;
      $self->host(shift) if @_;
      return undef unless defined $old;
      $old =~ s/.*@//;        # zap userinfo
      $old =~ s/:$//;         # empty port should be treated the same a no port
      $old .= ":" . $self->port unless $old =~ /:\d+$/;
      $old;
  }
  
  
  sub default_port { undef }
  
  sub canonical
  {
      my $self = shift;
      my $other = $self->SUPER::canonical;
      my $host = $other->host || "";
      my $port = $other->_port;
      my $uc_host = $host =~ /[A-Z]/;
      my $def_port = defined($port) && ($port eq "" ||
                                        $port == $self->default_port);
      if ($uc_host || $def_port) {
  	$other = $other->clone if $other == $self;
  	$other->host(lc $host) if $uc_host;
  	$other->port(undef)    if $def_port;
      }
      $other;
  }
  
  1;
URI__SERVER

$fatpacked{"URI/_userpass.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__USERPASS';
  package URI::_userpass;
  
  use strict;
  use warnings;
  
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub user
  {
      my $self = shift;
      my $info = $self->userinfo;
      if (@_) {
  	my $new = shift;
  	my $pass = defined($info) ? $info : "";
  	$pass =~ s/^[^:]*//;
  
  	if (!defined($new) && !length($pass)) {
  	    $self->userinfo(undef);
  	} else {
  	    $new = "" unless defined($new);
  	    $new =~ s/%/%25/g;
  	    $new =~ s/:/%3A/g;
  	    $self->userinfo("$new$pass");
  	}
      }
      return undef unless defined $info;
      $info =~ s/:.*//;
      uri_unescape($info);
  }
  
  sub password
  {
      my $self = shift;
      my $info = $self->userinfo;
      if (@_) {
  	my $new = shift;
  	my $user = defined($info) ? $info : "";
  	$user =~ s/:.*//;
  
  	if (!defined($new) && !length($user)) {
  	    $self->userinfo(undef);
  	} else {
  	    $new = "" unless defined($new);
  	    $new =~ s/%/%25/g;
  	    $self->userinfo("$user:$new");
  	}
      }
      return undef unless defined $info;
      return undef unless $info =~ s/^[^:]*://;
      uri_unescape($info);
  }
  
  1;
URI__USERPASS

$fatpacked{"URI/data.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_DATA';
  package URI::data;  # RFC 2397
  
  use strict;
  use warnings;
  
  use parent 'URI';
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use MIME::Base64 qw(encode_base64 decode_base64);
  use URI::Escape  qw(uri_unescape);
  
  sub media_type
  {
      my $self = shift;
      my $opaque = $self->opaque;
      $opaque =~ /^([^,]*),?/ or die;
      my $old = $1;
      my $base64;
      $base64 = $1 if $old =~ s/(;base64)$//i;
      if (@_) {
  	my $new = shift;
  	$new = "" unless defined $new;
  	$new =~ s/%/%25/g;
  	$new =~ s/,/%2C/g;
  	$base64 = "" unless defined $base64;
  	$opaque =~ s/^[^,]*,?/$new$base64,/;
  	$self->opaque($opaque);
      }
      return uri_unescape($old) if $old;  # media_type can't really be "0"
      "text/plain;charset=US-ASCII";      # default type
  }
  
  sub data
  {
      my $self = shift;
      my($enc, $data) = split(",", $self->opaque, 2);
      unless (defined $data) {
  	$data = "";
  	$enc  = "" unless defined $enc;
      }
      my $base64 = ($enc =~ /;base64$/i);
      if (@_) {
  	$enc =~ s/;base64$//i if $base64;
  	my $new = shift;
  	$new = "" unless defined $new;
  	my $uric_count = _uric_count($new);
  	my $urienc_len = $uric_count + (length($new) - $uric_count) * 3;
  	my $base64_len = int((length($new)+2) / 3) * 4;
  	$base64_len += 7;  # because of ";base64" marker
  	if ($base64_len < $urienc_len || $_[0]) {
  	    $enc .= ";base64";
  	    $new = encode_base64($new, "");
  	} else {
  	    $new =~ s/%/%25/g;
  	}
  	$self->opaque("$enc,$new");
      }
      return unless defined wantarray;
      $data = uri_unescape($data);
      return $base64 ? decode_base64($data) : $data;
  }
  
  # I could not find a better way to interpolate the tr/// chars from
  # a variable.
  my $ENC = $URI::uric;
  $ENC =~ s/%//;
  
  eval <<EOT; die $@ if $@;
  sub _uric_count
  {
      \$_[0] =~ tr/$ENC//;
  }
  EOT
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::data - URI that contains immediate data
  
  =head1 SYNOPSIS
  
   use URI;
  
   $u = URI->new("data:");
   $u->media_type("image/gif");
   $u->data(scalar(`cat camel.gif`));
   print "$u\n";
   open(XV, "|xv -") and print XV $u->data;
  
  =head1 DESCRIPTION
  
  The C<URI::data> class supports C<URI> objects belonging to the I<data>
  URI scheme.  The I<data> URI scheme is specified in RFC 2397.  It
  allows inclusion of small data items as "immediate" data, as if it had
  been included externally.  Examples:
  
    data:,Perl%20is%20good
  
    data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI
      AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG
      Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p
      KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI
      JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs=
  
  
  
  C<URI> objects belonging to the data scheme support the common methods
  (described in L<URI>) and the following two scheme-specific methods:
  
  =over 4
  
  =item $uri->media_type( [$new_media_type] )
  
  Can be used to get or set the media type specified in the
  URI.  If no media type is specified, then the default
  C<"text/plain;charset=US-ASCII"> is returned.
  
  =item $uri->data( [$new_data] )
  
  Can be used to get or set the data contained in the URI.
  The data is passed unescaped (in binary form).  The decision about
  whether to base64 encode the data in the URI is taken automatically,
  based on the encoding that produces the shorter URI string.
  
  =back
  
  =head1 SEE ALSO
  
  L<URI>
  
  =head1 COPYRIGHT
  
  Copyright 1995-1998 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
URI_DATA

$fatpacked{"URI/file.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE';
  package URI::file;
  
  use strict;
  use warnings;
  
  use parent 'URI::_generic';
  our $VERSION = "4.21";
  
  use URI::Escape qw(uri_unescape);
  
  our $DEFAULT_AUTHORITY = "";
  
  # Map from $^O values to implementation classes.  The Unix
  # class is the default.
  our %OS_CLASS = (
       os2     => "OS2",
       mac     => "Mac",
       MacOS   => "Mac",
       MSWin32 => "Win32",
       win32   => "Win32",
       msdos   => "FAT",
       dos     => "FAT",
       qnx     => "QNX",
  );
  
  sub os_class
  {
      my($OS) = shift || $^O;
  
      my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix");
      no strict 'refs';
      unless (%{"$class\::"}) {
  	eval "require $class";
  	die $@ if $@;
      }
      $class;
  }
  
  sub host { uri_unescape(shift->authority(@_)) }
  
  sub new
  {
      my($class, $path, $os) = @_;
      os_class($os)->new($path);
  }
  
  sub new_abs
  {
      my $class = shift;
      my $file = $class->new(@_);
      return $file->abs($class->cwd) unless $$file =~ /^file:/;
      $file;
  }
  
  sub cwd
  {
      my $class = shift;
      require Cwd;
      my $cwd = Cwd::cwd();
      $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS';
      $cwd = $class->new($cwd);
      $cwd .= "/" unless substr($cwd, -1, 1) eq "/";
      $cwd;
  }
  
  sub canonical {
      my $self = shift;
      my $other = $self->SUPER::canonical;
  
      my $scheme = $other->scheme;
      my $auth = $other->authority;
      return $other if !defined($scheme) && !defined($auth);  # relative
  
      if (!defined($auth) ||
  	$auth eq "" ||
  	lc($auth) eq "localhost" ||
  	(defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY))
         )
      {
  	# avoid cloning if $auth already match
  	if ((defined($auth) || defined($DEFAULT_AUTHORITY)) &&
  	    (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY)
  	   )
  	{
  	    $other = $other->clone if $self == $other;
  	    $other->authority($DEFAULT_AUTHORITY);
          }
      }
  
      $other;
  }
  
  sub file
  {
      my($self, $os) = @_;
      os_class($os)->file($self);
  }
  
  sub dir
  {
      my($self, $os) = @_;
      os_class($os)->dir($self);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::file - URI that maps to local file names
  
  =head1 SYNOPSIS
  
   use URI::file;
   
   $u1 = URI->new("file:/foo/bar");
   $u2 = URI->new("foo/bar", "file");
   
   $u3 = URI::file->new($path);
   $u4 = URI::file->new("c:\\windows\\", "win32");
   
   $u1->file;
   $u1->file("mac");
  
  =head1 DESCRIPTION
  
  The C<URI::file> class supports C<URI> objects belonging to the I<file>
  URI scheme.  This scheme allows us to map the conventional file names
  found on various computer systems to the URI name space.  An old
  specification of the I<file> URI scheme is found in RFC 1738.  Some
  older background information is also in RFC 1630. There are no newer
  specifications as far as I know.
  
  If you simply want to construct I<file> URI objects from URI strings,
  use the normal C<URI> constructor.  If you want to construct I<file>
  URI objects from the actual file names used by various systems, then
  use one of the following C<URI::file> constructors:
  
  =over 4
  
  =item $u = URI::file->new( $filename, [$os] )
  
  Maps a file name to the I<file:> URI name space, creates a URI object
  and returns it.  The $filename is interpreted as belonging to the
  indicated operating system ($os), which defaults to the value of the
  $^O variable.  The $filename can be either absolute or relative, and
  the corresponding type of URI object for $os is returned.
  
  =item $u = URI::file->new_abs( $filename, [$os] )
  
  Same as URI::file->new, but makes sure that the URI returned
  represents an absolute file name.  If the $filename argument is
  relative, then the name is resolved relative to the current directory,
  i.e. this constructor is really the same as:
  
    URI::file->new($filename)->abs(URI::file->cwd);
  
  =item $u = URI::file->cwd
  
  Returns a I<file> URI that represents the current working directory.
  See L<Cwd>.
  
  =back
  
  The following methods are supported for I<file> URI (in addition to
  the common and generic methods described in L<URI>):
  
  =over 4
  
  =item $u->file( [$os] )
  
  Returns a file name.  It maps from the URI name space
  to the file name space of the indicated operating system.
  
  It might return C<undef> if the name can not be represented in the
  indicated file system.
  
  =item $u->dir( [$os] )
  
  Some systems use a different form for names of directories than for plain
  files.  Use this method if you know you want to use the name for
  a directory.
  
  =back
  
  The C<URI::file> module can be used to map generic file names to names
  suitable for the current system.  As such, it can work as a nice
  replacement for the C<File::Spec> module.  For instance, the following
  code translates the UNIX-style file name F<Foo/Bar.pm> to a name
  suitable for the local system:
  
    $file = URI::file->new("Foo/Bar.pm", "unix")->file;
    die "Can't map filename Foo/Bar.pm for $^O" unless defined $file;
    open(FILE, $file) || die "Can't open '$file': $!";
    # do something with FILE
  
  =head1 MAPPING NOTES
  
  Most computer systems today have hierarchically organized file systems.
  Mapping the names used in these systems to the generic URI syntax
  allows us to work with relative file URIs that behave as they should
  when resolved using the generic algorithm for URIs (specified in RFC
  2396).  Mapping a file name to the generic URI syntax involves mapping
  the path separator character to "/" and encoding any reserved
  characters that appear in the path segments of the file name.  If
  path segments consisting of the strings "." or ".." have a
  different meaning than what is specified for generic URIs, then these
  must be encoded as well.
  
  If the file system has device, volume or drive specifications as
  the root of the name space, then it makes sense to map them to the
  authority field of the generic URI syntax.  This makes sure that
  relative URIs can not be resolved "above" them, i.e. generally how
  relative file names work in those systems.
  
  Another common use of the authority field is to encode the host on which
  this file name is valid.  The host name "localhost" is special and
  generally has the same meaning as a missing or empty authority
  field.  This use is in conflict with using it as a device
  specification, but can often be resolved for device specifications
  having characters not legal in plain host names.
  
  File name to URI mapping in normally not one-to-one.  There are
  usually many URIs that map to any given file name.  For instance, an
  authority of "localhost" maps the same as a URI with a missing or empty
  authority.
  
  Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator,
  but not in the same way as a generic URI. ":foo" was a relative name.  "foo:bar"
  was an absolute name.  Also, path segments could contain the "/" character as well
  as the literal "." or "..".  So the mapping looks like this:
  
    Mac classic           URI
    ----------            -------------------
    :foo:bar     <==>     foo/bar
    :            <==>     ./
    ::foo:bar    <==>     ../foo/bar
    :::          <==>     ../../
    foo:bar      <==>     file:/foo/bar
    foo:bar:     <==>     file:/foo/bar/
    ..           <==>     %2E%2E
    <undef>      <==      /
    foo/         <==      file:/foo%2F
    ./foo.txt    <==      file:/.%2Ffoo.txt
  
  Note that if you want a relative URL, you *must* begin the path with a :.  Any
  path that begins with [^:] is treated as absolute.
  
  Example 2: The UNIX file system is easy to map, as it uses the same path
  separator as URIs, has a single root, and segments of "." and ".."
  have the same meaning.  URIs that have the character "\0" or "/" as
  part of any path segment can not be turned into valid UNIX file names.
  
    UNIX                  URI
    ----------            ------------------
    foo/bar      <==>     foo/bar
    /foo/bar     <==>     file:/foo/bar
    /foo/bar     <==      file://localhost/foo/bar
    file:         ==>     ./file:
    <undef>      <==      file:/fo%00/bar
    /            <==>     file:/
  
  =cut
  
  
  RFC 1630
  
     [...]
  
     There is clearly a danger of confusion that a link made to a local
     file should be followed by someone on a different system, with
     unexpected and possibly harmful results.  Therefore, the convention
     is that even a "file" URL is provided with a host part.  This allows
     a client on another system to know that it cannot access the file
     system, or perhaps to use some other local mechanism to access the
     file.
  
     The special value "localhost" is used in the host field to indicate
     that the filename should really be used on whatever host one is.
     This for example allows links to be made to files which are
     distributed on many machines, or to "your unix local password file"
     subject of course to consistency across the users of the data.
  
     A void host field is equivalent to "localhost".
  
  =head1 CONFIGURATION VARIABLES
  
  The following configuration variables influence how the class and its
  methods behave:
  
  =over
  
  =item %URI::file::OS_CLASS
  
  This hash maps OS identifiers to implementation classes.  You might
  want to add or modify this if you want to plug in your own file
  handler class.  Normally the keys should match the $^O values in use.
  
  If there is no mapping then the "Unix" implementation is used.
  
  =item $URI::file::DEFAULT_AUTHORITY
  
  This determine what "authority" string to include in absolute file
  URIs.  It defaults to "".  If you prefer verbose URIs you might set it
  to be "localhost".
  
  Setting this value to C<undef> force behaviour compatible to URI v1.31
  and earlier.  In this mode host names in UNC paths and drive letters
  are mapped to the authority component on Windows, while we produce
  authority-less URIs on Unix.
  
  =back
  
  
  =head1 SEE ALSO
  
  L<URI>, L<File::Spec>, L<perlport>
  
  =head1 COPYRIGHT
  
  Copyright 1995-1998,2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
URI_FILE

$fatpacked{"URI/file/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_BASE';
  package URI::file::Base;
  
  use strict;
  use warnings;
  
  use URI::Escape qw();
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub new
  {
      my $class = shift;
      my $path  = shift;
      $path = "" unless defined $path;
  
      my($auth, $escaped_auth, $escaped_path);
  
      ($auth, $escaped_auth) = $class->_file_extract_authority($path);
      ($path, $escaped_path) = $class->_file_extract_path($path);
  
      if (defined $auth) {
  	$auth =~ s,%,%25,g unless $escaped_auth;
  	$auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
  	$auth = "//$auth";
  	if (defined $path) {
  	    $path = "/$path" unless substr($path, 0, 1) eq "/";
  	} else {
  	    $path = "";
  	}
      } else {
  	return undef unless defined $path;
  	$auth = "";
      }
  
      $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path;
      $path =~ s/\#/%23/g;
  
      my $uri = $auth . $path;
      $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
  
      URI->new($uri, "file");
  }
  
  sub _file_extract_authority
  {
      my($class, $path) = @_;
      return undef unless $class->_file_is_absolute($path);
      return $URI::file::DEFAULT_AUTHORITY;
  }
  
  sub _file_extract_path
  {
      return undef;
  }
  
  sub _file_is_absolute
  {
      return 0;
  }
  
  sub _file_is_localhost
  {
      shift; # class
      my $host = lc(shift);
      return 1 if $host eq "localhost";
      eval {
  	require Net::Domain;
  	lc(Net::Domain::hostfqdn()) eq $host ||
  	lc(Net::Domain::hostname()) eq $host;
      };
  }
  
  sub file
  {
      undef;
  }
  
  sub dir
  {
      my $self = shift;
      $self->file(@_);
  }
  
  1;
URI_FILE_BASE

$fatpacked{"URI/file/FAT.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_FAT';
  package URI::file::FAT;
  
  use strict;
  use warnings;
  
  use parent 'URI::file::Win32';
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub fix_path
  {
      shift; # class
      for (@_) {
  	# turn it into 8.3 names
  	my @p = map uc, split(/\./, $_, -1);
  	return if @p > 2;     # more than 1 dot is not allowed
  	@p = ("") unless @p;  # split bug? (returns nothing when splitting "")
  	$_ = substr($p[0], 0, 8);
          if (@p > 1) {
  	    my $ext = substr($p[1], 0, 3);
  	    $_ .= ".$ext" if length $ext;
  	}
      }
      1;  # ok
  }
  
  1;
URI_FILE_FAT

$fatpacked{"URI/file/Mac.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_MAC';
  package URI::file::Mac;
  
  use strict;
  use warnings;
  
  use parent 'URI::file::Base';
  
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub _file_extract_path
  {
      my $class = shift;
      my $path = shift;
  
      my @pre;
      if ($path =~ s/^(:+)//) {
  	if (length($1) == 1) {
  	    @pre = (".") unless length($path);
  	} else {
  	    @pre = ("..") x (length($1) - 1);
  	}
      } else { #absolute
  	$pre[0] = "";
      }
  
      my $isdir = ($path =~ s/:$//);
      $path =~ s,([%/;]), URI::Escape::escape_char($1),eg;
  
      my @path = split(/:/, $path, -1);
      for (@path) {
  	if ($_ eq "." || $_ eq "..") {
  	    $_ = "%2E" x length($_);
  	}
  	$_ = ".." unless length($_);
      }
      push (@path,"") if $isdir;
      (join("/", @pre, @path), 1);
  }
  
  
  sub file
  {
      my $class = shift;
      my $uri = shift;
      my @path;
  
      my $auth = $uri->authority;
      if (defined $auth) {
  	if (lc($auth) ne "localhost" && $auth ne "") {
  	    my $u_auth = uri_unescape($auth);
  	    if (!$class->_file_is_localhost($u_auth)) {
  		# some other host (use it as volume name)
  		@path = ("", $auth);
  		# XXX or just return to make it illegal;
  	    }
  	}
      }
      my @ps = split("/", $uri->path, -1);
      shift @ps if @path;
      push(@path, @ps);
  
      my $pre = "";
      if (!@path) {
  	return;  # empty path; XXX return ":" instead?
      } elsif ($path[0] eq "") {
  	# absolute
  	shift(@path);
  	if (@path == 1) {
  	    return if $path[0] eq "";  # not root directory
  	    push(@path, "");           # volume only, effectively append ":"
  	}
  	@ps = @path;
  	@path = ();
          my $part;
  	for (@ps) {  #fix up "." and "..", including interior, in relatives
  	    next if $_ eq ".";
  	    $part = $_ eq ".." ? "" : $_;
  	    push(@path,$part);
  	}
  	if ($ps[-1] eq "..") {  #if this happens, we need another :
  	    push(@path,"");
  	}
  	
      } else {
  	$pre = ":";
  	@ps = @path;
  	@path = ();
          my $part;
  	for (@ps) {  #fix up "." and "..", including interior, in relatives
  	    next if $_ eq ".";
  	    $part = $_ eq ".." ? "" : $_;
  	    push(@path,$part);
  	}
  	if ($ps[-1] eq "..") {  #if this happens, we need another :
  	    push(@path,"");
  	}
  	
      }
      return unless $pre || @path;
      for (@path) {
  	s/;.*//;  # get rid of parameters
  	#return unless length; # XXX
  	$_ = uri_unescape($_);
  	return if /\0/;
  	return if /:/;  # Should we?
      }
      $pre . join(":", @path);
  }
  
  sub dir
  {
      my $class = shift;
      my $path = $class->file(@_);
      return unless defined $path;
      $path .= ":" unless $path =~ /:$/;
      $path;
  }
  
  1;
URI_FILE_MAC

$fatpacked{"URI/file/OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_OS2';
  package URI::file::OS2;
  
  use strict;
  use warnings;
  
  use parent 'URI::file::Win32';
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  # The Win32 version translates k:/foo to file://k:/foo  (?!)
  # We add an empty host
  
  sub _file_extract_authority
  {
      my $class = shift;
      return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
      return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
  
      if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) {	      # allow for ab: drives
  	return "";
      }
      return;
  }
  
  sub file {
    my $p = &URI::file::Win32::file;
    return unless defined $p;
    $p =~ s,\\,/,g;
    $p;
  }
  
  1;
URI_FILE_OS2

$fatpacked{"URI/file/QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_QNX';
  package URI::file::QNX;
  
  use strict;
  use warnings;
  
  use parent 'URI::file::Unix';
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub _file_extract_path
  {
      my($class, $path) = @_;
      # tidy path
      $path =~ s,(.)//+,$1/,g; # ^// is correct
      $path =~ s,(/\.)+/,/,g;
      $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
      $path;
  }
  
  1;
URI_FILE_QNX

$fatpacked{"URI/file/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_UNIX';
  package URI::file::Unix;
  
  use strict;
  use warnings;
  
  use parent 'URI::file::Base';
  
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub _file_extract_path
  {
      my($class, $path) = @_;
  
      # tidy path
      $path =~ s,//+,/,g;
      $path =~ s,(/\.)+/,/,g;
      $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
  
      return $path;
  }
  
  sub _file_is_absolute {
      my($class, $path) = @_;
      return $path =~ m,^/,;
  }
  
  sub file
  {
      my $class = shift;
      my $uri = shift;
      my @path;
  
      my $auth = $uri->authority;
      if (defined($auth)) {
  	if (lc($auth) ne "localhost" && $auth ne "") {
  	    $auth = uri_unescape($auth);
  	    unless ($class->_file_is_localhost($auth)) {
  		push(@path, "", "", $auth);
  	    }
  	}
      }
  
      my @ps = $uri->path_segments;
      shift @ps if @path;
      push(@path, @ps);
  
      for (@path) {
  	# Unix file/directory names are not allowed to contain '\0' or '/'
  	return undef if /\0/;
  	return undef if /\//;  # should we really?
      }
  
      return join("/", @path);
  }
  
  1;
URI_FILE_UNIX

$fatpacked{"URI/file/Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_WIN32';
  package URI::file::Win32;
  
  use strict;
  use warnings;
  
  use parent 'URI::file::Base';
  
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub _file_extract_authority
  {
      my $class = shift;
  
      return $class->SUPER::_file_extract_authority($_[0])
  	if defined $URI::file::DEFAULT_AUTHORITY;
  
      return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
      return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
  
      if ($_[0] =~ s,^([a-zA-Z]:),,) {
  	my $auth = $1;
  	$auth .= "relative" if $_[0] !~ m,^[\\/],;
  	return $auth;
      }
      return undef;
  }
  
  sub _file_extract_path
  {
      my($class, $path) = @_;
      $path =~ s,\\,/,g;
      #$path =~ s,//+,/,g;
      $path =~ s,(/\.)+/,/,g;
  
      if (defined $URI::file::DEFAULT_AUTHORITY) {
  	$path =~ s,^([a-zA-Z]:),/$1,;
      }
  
      return $path;
  }
  
  sub _file_is_absolute {
      my($class, $path) = @_;
      return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
  }
  
  sub file
  {
      my $class = shift;
      my $uri = shift;
      my $auth = $uri->authority;
      my $rel; # is filename relative to drive specified in authority
      if (defined $auth) {
          $auth = uri_unescape($auth);
  	if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
  	    $auth = uc($1) . ":";
  	    $rel++ if $2;
  	} elsif (lc($auth) eq "localhost") {
  	    $auth = "";
  	} elsif (length $auth) {
  	    $auth = "\\\\" . $auth;  # UNC
  	}
      } else {
  	$auth = "";
      }
  
      my @path = $uri->path_segments;
      for (@path) {
  	return undef if /\0/;
  	return undef if /\//;
  	#return undef if /\\/;        # URLs with "\" is not uncommon
      }
      return undef unless $class->fix_path(@path);
  
      my $path = join("\\", @path);
      $path =~ s/^\\// if $rel;
      $path = $auth . $path;
      $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
  
      return $path;
  }
  
  sub fix_path { 1; }
  
  1;
URI_FILE_WIN32

$fatpacked{"URI/ftp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FTP';
  package URI::ftp;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent qw(URI::_server URI::_userpass);
  
  sub default_port { 21 }
  
  sub path { shift->path_query(@_) }  # XXX
  
  sub _user     { shift->SUPER::user(@_);     }
  sub _password { shift->SUPER::password(@_); }
  
  sub user
  {
      my $self = shift;
      my $user = $self->_user(@_);
      $user = "anonymous" unless defined $user;
      $user;
  }
  
  sub password
  {
      my $self = shift;
      my $pass = $self->_password(@_);
      unless (defined $pass) {
  	my $user = $self->user;
  	if ($user eq 'anonymous' || $user eq 'ftp') {
  	    # anonymous ftp login password
              # If there is no ftp anonymous password specified
              # then we'll just use 'anonymous@'
              # We don't try to send the read e-mail address because:
              # - We want to remain anonymous
              # - We want to stop SPAM
              # - We don't want to let ftp sites to discriminate by the user,
              #   host, country or ftp client being used.
  	    $pass = 'anonymous@';
  	}
      }
      $pass;
  }
  
  1;
URI_FTP

$fatpacked{"URI/gopher.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_GOPHER';
  package URI::gopher;  # <draft-murali-url-gopher>, Dec 4, 1996
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_server';
  
  use URI::Escape qw(uri_unescape);
  
  #  A Gopher URL follows the common internet scheme syntax as defined in 
  #  section 4.3 of [RFC-URL-SYNTAX]:
  #
  #        gopher://<host>[:<port>]/<gopher-path>
  #
  #  where
  #
  #        <gopher-path> :=  <gopher-type><selector> | 
  #                          <gopher-type><selector>%09<search> |
  #                          <gopher-type><selector>%09<search>%09<gopher+_string>
  #
  #        <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7'
  #                         '8' | '9' | '+' | 'I' | 'g' | 'T'
  #
  #        <selector>    := *pchar     Refer to RFC 1808 [4]
  #        <search>      := *pchar
  #        <gopher+_string> := *uchar  Refer to RFC 1738 [3]
  #        
  #  If the optional port is omitted, the port defaults to 70. 
  
  sub default_port { 70 }
  
  sub _gopher_type
  {
      my $self = shift;
      my $path = $self->path_query;
      $path =~ s,^/,,;
      my $gtype = $1 if $path =~ s/^(.)//s;
      if (@_) {
  	my $new_type = shift;
  	if (defined($new_type)) {
  	    Carp::croak("Bad gopher type '$new_type'")
                 unless length($new_type) == 1;
  	    substr($path, 0, 0) = $new_type;
  	    $self->path_query($path);
  	} else {
  	    Carp::croak("Can't delete gopher type when selector is present")
  		if length($path);
  	    $self->path_query(undef);
  	}
      }
      return $gtype;
  }
  
  sub gopher_type
  {
      my $self = shift;
      my $gtype = $self->_gopher_type(@_);
      $gtype = "1" unless defined $gtype;
      $gtype;
  }
  
  sub gtype { goto &gopher_type }  # URI::URL compatibility
  
  sub selector { shift->_gfield(0, @_) }
  sub search   { shift->_gfield(1, @_) }
  sub string   { shift->_gfield(2, @_) }
  
  sub _gfield
  {
      my $self = shift;
      my $fno  = shift;
      my $path = $self->path_query;
  
      # not according to spec., but many popular browsers accept
      # gopher URLs with a '?' before the search string.
      $path =~ s/\?/\t/;
      $path = uri_unescape($path);
      $path =~ s,^/,,;
      my $gtype = $1 if $path =~ s,^(.),,s;
      my @path = split(/\t/, $path, 3);
      if (@_) {
  	# modify
  	my $new = shift;
  	$path[$fno] = $new;
  	pop(@path) while @path && !defined($path[-1]);
  	for (@path) { $_="" unless defined }
  	$path = $gtype;
  	$path = "1" unless defined $path;
  	$path .= join("\t", @path);
  	$self->path_query($path);
      }
      $path[$fno];
  }
  
  1;
URI_GOPHER

$fatpacked{"URI/http.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_HTTP';
  package URI::http;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_server';
  
  sub default_port { 80 }
  
  sub canonical
  {
      my $self = shift;
      my $other = $self->SUPER::canonical;
  
      my $slash_path = defined($other->authority) &&
          !length($other->path) && !defined($other->query);
  
      if ($slash_path) {
  	$other = $other->clone if $other == $self;
  	$other->path("/");
      }
      $other;
  }
  
  1;
URI_HTTP

$fatpacked{"URI/https.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_HTTPS';
  package URI::https;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::http';
  
  sub default_port { 443 }
  
  sub secure { 1 }
  
  1;
URI_HTTPS

$fatpacked{"URI/ldap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_LDAP';
  # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
  # This program is free software; you can redistribute it and/or
  # modify it under the same terms as Perl itself.
  
  package URI::ldap;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent qw(URI::_ldap URI::_server);
  
  sub default_port { 389 }
  
  sub _nonldap_canonical {
      my $self = shift;
      $self->URI::_server::canonical(@_);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::ldap - LDAP Uniform Resource Locators
  
  =head1 SYNOPSIS
  
    use URI;
  
    $uri = URI->new("ldap:$uri_string");
    $dn     = $uri->dn;
    $filter = $uri->filter;
    @attr   = $uri->attributes;
    $scope  = $uri->scope;
    %extn   = $uri->extensions;
    
    $uri = URI->new("ldap:");  # start empty
    $uri->host("ldap.itd.umich.edu");
    $uri->dn("o=University of Michigan,c=US");
    $uri->attributes(qw(postalAddress));
    $uri->scope('sub');
    $uri->filter('(cn=Babs Jensen)');
    print $uri->as_string,"\n";
  
  =head1 DESCRIPTION
  
  C<URI::ldap> provides an interface to parse an LDAP URI into its
  constituent parts and also to build a URI as described in
  RFC 2255.
  
  =head1 METHODS
  
  C<URI::ldap> supports all the generic and server methods defined by
  L<URI>, plus the following.
  
  Each of the following methods can be used to set or get the value in
  the URI. The values are passed in unescaped form.  None of these
  return undefined values, but elements without a default can be empty.
  If arguments are given, then a new value is set for the given part
  of the URI.
  
  =over 4
  
  =item $uri->dn( [$new_dn] )
  
  Sets or gets the I<Distinguished Name> part of the URI.  The DN
  identifies the base object of the LDAP search.
  
  =item $uri->attributes( [@new_attrs] )
  
  Sets or gets the list of attribute names which are
  returned by the search.
  
  =item $uri->scope( [$new_scope] )
  
  Sets or gets the scope to be used by the search. The value can be one of
  C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the
  return value defaults to C<"base">.
  
  =item $uri->_scope( [$new_scope] )
  
  Same as scope(), but does not default to anything.
  
  =item $uri->filter( [$new_filter] )
  
  Sets or gets the filter to be used by the search. If none is given in
  the URI then the return value defaults to C<"(objectClass=*)">.
  
  =item $uri->_filter( [$new_filter] )
  
  Same as filter(), but does not default to anything.
  
  =item $uri->extensions( [$etype => $evalue,...] )
  
  Sets or gets the extensions used for the search. The list passed should
  be in the form etype1 => evalue1, etype2 => evalue2,... This is also
  the form of list that is returned.
  
  =back
  
  =head1 SEE ALSO
  
  L<http://tools.ietf.org/html/rfc2255>
  
  =head1 AUTHOR
  
  Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
  
  Slightly modified by Gisle Aas to fit into the URI distribution.
  
  =head1 COPYRIGHT
  
  Copyright (c) 1998 Graham Barr. All rights reserved. This program is
  free software; you can redistribute it and/or modify it under the same
  terms as Perl itself.
  
  =cut
URI_LDAP

$fatpacked{"URI/ldapi.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_LDAPI';
  package URI::ldapi;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent qw(URI::_ldap URI::_generic);
  
  require URI::Escape;
  
  sub un_path {
      my $self = shift;
      my $old = URI::Escape::uri_unescape($self->authority);
      if (@_) {
  	my $p = shift;
  	$p =~ s/:/%3A/g;
  	$p =~ s/\@/%40/g;
  	$self->authority($p);
      }
      return $old;
  }
  
  sub _nonldap_canonical {
      my $self = shift;
      $self->URI::_generic::canonical(@_);
  }
  
  1;
URI_LDAPI

$fatpacked{"URI/ldaps.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_LDAPS';
  package URI::ldaps;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::ldap';
  
  sub default_port { 636 }
  
  sub secure { 1 }
  
  1;
URI_LDAPS

$fatpacked{"URI/mailto.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_MAILTO';
  package URI::mailto;  # RFC 2368
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent qw(URI URI::_query);
  
  sub to
  {
      my $self = shift;
      my @old = $self->headers;
      if (@_) {
  	my @new = @old;
  	# get rid of any other to: fields
  	for (my $i = 0; $i < @new; $i += 2) {
  	    if (lc($new[$i] || '') eq "to") {
  		splice(@new, $i, 2);
  		redo;
  	    }
  	}
  
  	my $to = shift;
  	$to = "" unless defined $to;
  	unshift(@new, "to" => $to);
  	$self->headers(@new);
      }
      return unless defined wantarray;
  
      my @to;
      while (@old) {
  	my $h = shift @old;
  	my $v = shift @old;
  	push(@to, $v) if lc($h) eq "to";
      }
      join(",", @to);
  }
  
  
  sub headers
  {
      my $self = shift;
  
      # The trick is to just treat everything as the query string...
      my $opaque = "to=" . $self->opaque;
      $opaque =~ s/\?/&/;
  
      if (@_) {
  	my @new = @_;
  
  	# strip out any "to" fields
  	my @to;
  	for (my $i=0; $i < @new; $i += 2) {
  	    if (lc($new[$i] || '') eq "to") {
  		push(@to, (splice(@new, $i, 2))[1]);  # remove header
  		redo;
  	    }
  	}
  
  	my $new = join(",",@to);
  	$new =~ s/%/%25/g;
  	$new =~ s/\?/%3F/g;
  	$self->opaque($new);
  	$self->query_form(@new) if @new;
      }
      return unless defined wantarray;
  
      # I am lazy today...
      URI->new("mailto:?$opaque")->query_form;
  }
  
  1;
URI_MAILTO

$fatpacked{"URI/mms.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_MMS';
  package URI::mms;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::http';
  
  sub default_port { 1755 }
  
  1;
URI_MMS

$fatpacked{"URI/news.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_NEWS';
  package URI::news;  # draft-gilman-news-url-01
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_server';
  
  use URI::Escape qw(uri_unescape);
  use Carp ();
  
  sub default_port { 119 }
  
  #   newsURL      =  scheme ":" [ news-server ] [ refbygroup | message ]
  #   scheme       =  "news" | "snews" | "nntp"
  #   news-server  =  "//" server "/"
  #   refbygroup   = group [ "/" messageno [ "-" messageno ] ]
  #   message      = local-part "@" domain
  
  sub _group
  {
      my $self = shift;
      my $old = $self->path;
      if (@_) {
  	my($group,$from,$to) = @_;
  	if ($group =~ /\@/) {
              $group =~ s/^<(.*)>$/$1/;  # "<" and ">" should not be part of it
  	}
  	$group =~ s,%,%25,g;
  	$group =~ s,/,%2F,g;
  	my $path = $group;
  	if (defined $from) {
  	    $path .= "/$from";
  	    $path .= "-$to" if defined $to;
  	}
  	$self->path($path);
      }
  
      $old =~ s,^/,,;
      if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) {
  	my $extra = $1;
  	return (uri_unescape($old), split(/-/, $extra));
      }
      uri_unescape($old);
  }
  
  
  sub group
  {
      my $self = shift;
      if (@_) {
  	Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/;
      }
      my @old = $self->_group(@_);
      return if $old[0] =~ /\@/;
      wantarray ? @old : $old[0];
  }
  
  sub message
  {
      my $self = shift;
      if (@_) {
  	Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/;
      }
      my $old = $self->_group(@_);
      return undef unless $old =~ /\@/;
      return $old;
  }
  
  1;
URI_NEWS

$fatpacked{"URI/nntp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_NNTP';
  package URI::nntp;  # draft-gilman-news-url-01
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::news';
  
  1;
URI_NNTP

$fatpacked{"URI/pop.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_POP';
  package URI::pop;   # RFC 2384
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_server';
  
  use URI::Escape qw(uri_unescape);
  
  sub default_port { 110 }
  
  #pop://<user>;auth=<auth>@<host>:<port>
  
  sub user
  {
      my $self = shift;
      my $old = $self->userinfo;
  
      if (@_) {
  	my $new_info = $old;
  	$new_info = "" unless defined $new_info;
  	$new_info =~ s/^[^;]*//;
  
  	my $new = shift;
  	if (!defined($new) && !length($new_info)) {
  	    $self->userinfo(undef);
  	} else {
  	    $new = "" unless defined $new;
  	    $new =~ s/%/%25/g;
  	    $new =~ s/;/%3B/g;
  	    $self->userinfo("$new$new_info");
  	}
      }
  
      return undef unless defined $old;
      $old =~ s/;.*//;
      return uri_unescape($old);
  }
  
  sub auth
  {
      my $self = shift;
      my $old = $self->userinfo;
  
      if (@_) {
  	my $new = $old;
  	$new = "" unless defined $new;
  	$new =~ s/(^[^;]*)//;
  	my $user = $1;
  	$new =~ s/;auth=[^;]*//i;
  
  	
  	my $auth = shift;
  	if (defined $auth) {
  	    $auth =~ s/%/%25/g;
  	    $auth =~ s/;/%3B/g;
  	    $new = ";AUTH=$auth$new";
  	}
  	$self->userinfo("$user$new");
  	
      }
  
      return undef unless defined $old;
      $old =~ s/^[^;]*//;
      return uri_unescape($1) if $old =~ /;auth=(.*)/i;
      return;
  }
  
  1;
URI_POP

$fatpacked{"URI/rlogin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RLOGIN';
  package URI::rlogin;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_login';
  
  sub default_port { 513 }
  
  1;
URI_RLOGIN

$fatpacked{"URI/rsync.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RSYNC';
  package URI::rsync;  # http://rsync.samba.org/
  
  # rsync://[USER@]HOST[:PORT]/SRC
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent qw(URI::_server URI::_userpass);
  
  sub default_port { 873 }
  
  1;
URI_RSYNC

$fatpacked{"URI/rtsp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RTSP';
  package URI::rtsp;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::http';
  
  sub default_port { 554 }
  
  1;
URI_RTSP

$fatpacked{"URI/rtspu.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RTSPU';
  package URI::rtspu;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::rtsp';
  
  sub default_port { 554 }
  
  1;
URI_RTSPU

$fatpacked{"URI/sftp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SFTP';
  package URI::sftp;
  
  use strict;
  use warnings;
  
  use parent 'URI::ssh';
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  1;
URI_SFTP

$fatpacked{"URI/sip.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SIP';
  #
  # Written by Ryan Kereliuk <ryker@ryker.org>.  This file may be
  # distributed under the same terms as Perl itself.
  #
  # The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>.
  #
  
  package URI::sip;
  
  use strict;
  use warnings;
  
  use parent qw(URI::_server URI::_userpass);
  
  use URI::Escape qw(uri_unescape);
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  sub default_port { 5060 }
  
  sub authority
  {
      my $self = shift;
      $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
      my $old = $2;
  
      if (@_) {
          my $auth = shift;
          $$self = defined($1) ? $1 : "";
          my $rest = $3;
          if (defined $auth) {
              $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
              $$self .= "$auth";
          }
          $$self .= $rest;
      }
      $old;
  }
  
  sub params_form
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
      my $paramstr = $3;
  
      if (@_) {
      	my @args = @_; 
          $$self = $1 . $2;
          my $rest = $4;
  	my @new;
  	for (my $i=0; $i < @args; $i += 2) {
  	    push(@new, "$args[$i]=$args[$i+1]");
  	}
  	$paramstr = join(";", @new);
  	$$self .= ";" . $paramstr . $rest;
      }
      $paramstr =~ s/^;//o;
      return split(/[;=]/, $paramstr);
  }
  
  sub params
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
      my $paramstr = $3;
  
      if (@_) {
      	my $new = shift; 
          $$self = $1 . $2;
          my $rest = $4;
  	$$self .= $paramstr . $rest;
      }
      $paramstr =~ s/^;//o;
      return $paramstr;
  }
  
  # Inherited methods that make no sense for a SIP URI.
  sub path {}
  sub path_query {}
  sub path_segments {}
  sub abs { shift }
  sub rel { shift }
  sub query_keywords {}
  
  1;
URI_SIP

$fatpacked{"URI/sips.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SIPS';
  package URI::sips;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::sip';
  
  sub default_port { 5061 }
  
  sub secure { 1 }
  
  1;
URI_SIPS

$fatpacked{"URI/snews.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SNEWS';
  package URI::snews;  # draft-gilman-news-url-01
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::news';
  
  sub default_port { 563 }
  
  sub secure { 1 }
  
  1;
URI_SNEWS

$fatpacked{"URI/ssh.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SSH';
  package URI::ssh;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_login';
  
  # ssh://[USER@]HOST[:PORT]/SRC
  
  sub default_port { 22 }
  
  sub secure { 1 }
  
  1;
URI_SSH

$fatpacked{"URI/telnet.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_TELNET';
  package URI::telnet;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_login';
  
  sub default_port { 23 }
  
  1;
URI_TELNET

$fatpacked{"URI/tn3270.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_TN3270';
  package URI::tn3270;
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::_login';
  
  sub default_port { 23 }
  
  1;
URI_TN3270

$fatpacked{"URI/urn.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URN';
  package URI::urn;  # RFC 2141
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI';
  
  use Carp qw(carp);
  
  my %implementor;
  my %require_attempted;
  
  sub _init {
      my $class = shift;
      my $self = $class->SUPER::_init(@_);
      my $nid = $self->nid;
  
      my $impclass = $implementor{$nid};
      return $impclass->_urn_init($self, $nid) if $impclass;
  
      $impclass = "URI::urn";
      if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) {
  	my $id = $nid;
  	# make it a legal perl identifier
  	$id =~ s/-/_/g;
  	$id = "_$id" if $id =~ /^\d/;
  
  	$impclass = "URI::urn::$id";
  	no strict 'refs';
  	unless (@{"${impclass}::ISA"}) {
              if (not exists $require_attempted{$impclass}) {
                  # Try to load it
                  my $_old_error = $@;
                  eval "require $impclass";
                  die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
                  $@ = $_old_error;
              }
  	    $impclass = "URI::urn" unless @{"${impclass}::ISA"};
  	}
      }
      else {
  	carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W;
      }
      $implementor{$nid} = $impclass;
  
      return $impclass->_urn_init($self, $nid);
  }
  
  sub _urn_init {
      my($class, $self, $nid) = @_;
      bless $self, $class;
  }
  
  sub _nid {
      my $self = shift;
      my $opaque = $self->opaque;
      if (@_) {
  	my $v = $opaque;
  	my $new = shift;
  	$v =~ s/[^:]*/$new/;
  	$self->opaque($v);
  	# XXX possible rebless
      }
      $opaque =~ s/:.*//s;
      return $opaque;
  }
  
  sub nid {  # namespace identifier
      my $self = shift;
      my $nid = $self->_nid(@_);
      $nid = lc($nid) if defined($nid);
      return $nid;
  }
  
  sub nss {  # namespace specific string
      my $self = shift;
      my $opaque = $self->opaque;
      if (@_) {
  	my $v = $opaque;
  	my $new = shift;
  	if (defined $new) {
  	    $v =~ s/(:|\z).*/:$new/;
  	}
  	else {
  	    $v =~ s/:.*//s;
  	}
  	$self->opaque($v);
      }
      return undef unless $opaque =~ s/^[^:]*://;
      return $opaque;
  }
  
  sub canonical {
      my $self = shift;
      my $nid = $self->_nid;
      my $new = $self->SUPER::canonical;
      return $new if $nid !~ /[A-Z]/ || $nid =~ /%/;
      $new = $new->clone if $new == $self;
      $new->nid(lc($nid));
      return $new;
  }
  
  1;
URI_URN

$fatpacked{"URI/urn/isbn.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URN_ISBN';
  package URI::urn::isbn;  # RFC 3187
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  
  use parent 'URI::urn';
  
  use Carp qw(carp);
  
  BEGIN {
      require Business::ISBN;
      
      local $^W = 0; # don't warn about dev versions, perl5.004 style
      warn "Using Business::ISBN version " . Business::ISBN->VERSION . 
          " which is deprecated.\nUpgrade to Business::ISBN version 2\n"
          if Business::ISBN->VERSION < 2;
      }
      
  sub _isbn {
      my $nss = shift;
      $nss = $nss->nss if ref($nss);
      my $isbn = Business::ISBN->new($nss);
      $isbn = undef if $isbn && !$isbn->is_valid;
      return $isbn;
  }
  
  sub _nss_isbn {
      my $self = shift;
      my $nss = $self->nss(@_);
      my $isbn = _isbn($nss);
      $isbn = $isbn->as_string if $isbn;
      return($nss, $isbn);
  }
  
  sub isbn {
      my $self = shift;
      my $isbn;
      (undef, $isbn) = $self->_nss_isbn(@_);
      return $isbn;
  }
  
  sub isbn_publisher_code {
      my $isbn = shift->_isbn || return undef;
      return $isbn->publisher_code;
  }
  
  BEGIN {
  my $group_method = do {
      local $^W = 0; # don't warn about dev versions, perl5.004 style
      Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code';
      };
  
  sub isbn_group_code {
      my $isbn = shift->_isbn || return undef;
      return $isbn->$group_method;
  }
  }
  
  sub isbn_country_code {
      my $name = (caller(0))[3]; $name =~ s/.*:://;
      carp "$name is DEPRECATED. Use isbn_group_code instead";
      
      no strict 'refs';
      &isbn_group_code;
  }
  
  BEGIN {
  my $isbn13_method = do {
      local $^W = 0; # don't warn about dev versions, perl5.004 style
      Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean';
      };
  
  sub isbn13 {
      my $isbn = shift->_isbn || return undef;
      
      # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string
      # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects
      #   and it uses the hyphens, so call as_string with an empty anon array
      # or, adjust the test and features to say that it comes out with hyphens.
      my $thingy = $isbn->$isbn13_method;
      return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy;
  }
  }
  
  sub isbn_as_ean {
      my $name = (caller(0))[3]; $name =~ s/.*:://;
      carp "$name is DEPRECATED. Use isbn13 instead";
  
      no strict 'refs';
      &isbn13;
  }
  
  sub canonical {
      my $self = shift;
      my($nss, $isbn) = $self->_nss_isbn;
      my $new = $self->SUPER::canonical;
      return $new unless $nss && $isbn && $nss ne $isbn;
      $new = $new->clone if $new == $self;
      $new->nss($isbn);
      return $new;
  }
  
  1;
URI_URN_ISBN

$fatpacked{"URI/urn/oid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URN_OID';
  package URI::urn::oid;  # RFC 2061
  
  use strict;
  use warnings;
  
  our $VERSION = '1.73';
  $VERSION = eval $VERSION;
  
  use parent 'URI::urn';
  
  sub oid {
      my $self = shift;
      my $old = $self->nss;
      if (@_) {
  	$self->nss(join(".", @_));
      }
      return split(/\./, $old) if wantarray;
      return $old;
  }
  
  1;
URI_URN_OID

$fatpacked{"Win32/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'WIN32_SHELLQUOTE';
  package Win32::ShellQuote;
  use strict;
  use warnings FATAL => 'all';
  use base 'Exporter';
  use Carp;
  
  our $VERSION = '0.003001';
  $VERSION = eval $VERSION;
  
  our @EXPORT_OK = qw(
      quote_native
      quote_cmd
      quote_system_list
      quote_system_string
      quote_system
      quote_system_cmd
      quote_literal
      cmd_escape
      unquote_native
      cmd_unescape
  );
  our %EXPORT_TAGS = (all => [@EXPORT_OK]);
  
  sub quote_native {
      return join q{ }, quote_system_list(@_);
  }
  
  sub quote_cmd {
      return cmd_escape(quote_native(@_));
  }
  
  sub quote_system_list {
      # have to force quoting, or perl might try to use cmd anyway
      return map { quote_literal($_, 1) } @_;
  }
  
  sub quote_system_string {
      my $args = quote_native(@_);
  
      if (_has_shell_metachars($args)) {
          $args = cmd_escape($args);
      }
      return $args;
  }
  
  sub quote_system {
      if (@_ > 1) {
          return quote_system_list(@_);
      }
      else {
          return quote_system_string(@_);
      }
  }
  
  sub quote_system_cmd {
      # force cmd, even when running through system
      my $args = quote_native(@_);
  
      if (! _has_shell_metachars($args)) {
          # IT BURNS LOOK AWAY
          return '%PATH:~0,0%' . cmd_escape($args);
      }
      return cmd_escape($args);
  }
  
  
  sub cmd_escape {
      my $string = shift;
      if ($string =~ /[\r\n\0]/) {
          croak "can't quote newlines to pass through cmd.exe";
      }
      $string =~ s/([()%!^"<>&|])/^$1/g;
      return $string;
  }
  
  sub quote_literal {
      my ($text, $force) = @_;
  
      # basic argument quoting.  uses backslashes and quotes to escape
      # everything.
      if (!$force && $text ne '' && $text !~ /[ \t\n\x0b"]/) {
          # no quoting needed
      }
      else {
          $text =~ s{(\\*)(?="|\z)}{$1$1}g;
          $text =~ s{"}{\\"}g;
          $text = qq{"$text"};
      }
  
      return $text;
  }
  
  # derived from rules in code in win32.c
  sub _has_shell_metachars {
      my $string = shift;
  
      return 1
          if $string =~ /%/;
      $string =~ s/(['"]).*?(\1|\z)//sg;
      return $string =~ /[<>|]/;
  }
  
  sub unquote_native {
      local ($_) = @_;
      my @argv;
  
      my $length = length
          or return @argv;
  
      m/\G\s*/gc;
  
      ARGS: until ( pos == $length ) {
          my $quote_mode;
          my $arg = '';
          CHARS: until ( pos == $length ) {
              if ( m/\G((?:\\\\)+)(?=\\?(")?)/gc ) {
                  if (defined $2) {
                      $arg .= '\\' x (length($1) / 2);
                  }
                  else {
                      $arg .= $1;
                  }
              }
              elsif ( m/\G\\"/gc ) {
                  $arg .= '"';
              }
              elsif ( m/\G"/gc ) {
                  if ( $quote_mode && m/\G"/gc ) {
                      $arg .= '"';
                  }
                  $quote_mode = !$quote_mode;
              }
              elsif ( !$quote_mode && m/\G\s+/gc ) {
                  last;
              }
              elsif ( m/\G(.)/sgc ) {
                  $arg .= $1;
              }
          }
          push @argv, $arg;
      }
  
      return @argv;
  }
  
  sub cmd_unescape {
      my ($string) = @_;
  
      no warnings 'uninitialized';
      $string =~ s/\^(.?)|([^^"]+)|("[^"]*(?:"|\z))/$1$2$3/gs;
  
      return $string;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Win32::ShellQuote - Quote argument lists for Win32
  
  =head1 SYNOPSIS
  
      use Win32::ShellQuote qw(:all);
  
      system quote_system('program.exe', '--switch', 'argument with spaces or other special characters');
  
  =head1 DESCRIPTION
  
  Quotes argument lists to be used in Win32 in several different
  situations.
  
  Windows passes its arguments as a single string instead of an array
  as other platforms do.  In almost all cases, the standard Win32
  L<CommandLineToArgvW|http://msdn.microsoft.com/en-us/library/ms647232.aspx>
  function is used to parse this string.  F<cmd.exe> has different
  rules for handling quoting, so extra work has to be done if it is
  involved.  It isn't possible to consistantly create a single string
  that will be handled the same by F<cmd.exe> and the stardard parsing
  rules.
  
  Perl will try to detect if you need the shell by detecting shell
  metacharacters.  The routine that checks that uses different quoting
  rules from both F<cmd.exe> and the native Win32 parsing.  Extra
  work must therefore be done to protect against this autodetection.
  
  =head1 SUBROUTINES
  
  =head2 quote_native
  
  Quotes as a string to pass directly to a program using native methods
  like L<Win32::Spawn()|Win32>.  This is the safest option to use if
  possible.
  
  =head2 quote_cmd
  
  Quotes as a string to be run through F<cmd.exe>, such as in a batch file.
  
  =head2 quote_system_list
  
  Quotes as a list to be passed to L<system|perlfunc/system> or
  L<exec|perlfunc/exec>.  This is equally as safe as L</quote_native>,
  but you must ensure you have more than one item being quoted for
  the list to be usable with system.
  
  =head2 quote_system_string
  
  Like L</quote_system_list>, but returns a single string.  Some
  argument lists cannot be properly quoted using this function.
  
  =head2 quote_system
  
  Switches between L</quote_system_list> and L</quote_system_string>
  based on the number of items quoted.
  
  =head2 quote_system_cmd
  
  Quotes as a single string that will always be run with F<cmd.exe>.
  
  =head2 quote_literal
  
  Quotes a single parameter in native form.
  
  =head2 cmd_escape
  
  Escapes a string to be passed untouched by F<cmd.exe>.
  
  =head1 CAVEATS
  
  =over
  
  =item *
  
  Newlines (\n or \r) and null (\0) can't be properly quoted when
  running through F<cmd.exe>.
  
  =item *
  
  This module re-implements some under-specified part of the perl
  internals to accurately perform its work.
  
  =back
  
  =head1 AUTHOR
  
  haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
  
  =head1 CONTRIBUTORS
  
  =over 8
  
  =item * Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (c) 2012 the L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  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
WIN32_SHELLQUOTE

$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.000024';
  $VERSION = eval $VERSION;
  
  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::Cwd()
      if _WIN32 && defined &Win32::Cwd && !$drive;
    local @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 =~ /^--/ ) {
        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$/ ? " ^"._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.
  
  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, as follows:
  
    perl Makefile.PL --bootstrap=~/foo
  
  =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:
  
    /bin/csh
    echo $SHELL
    /bin/csh
    echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc
  
  If you passed to bootstrap a directory other than default, you also need to
  give that as import parameter to the call of the local::lib module like this
  way:
  
    echo 'eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc
  
  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
  
  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 --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 installed, uses C<File::HomeDir>
  for this purpose. 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

$fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT';
  package parent;
  use strict;
  use vars qw($VERSION);
  $VERSION = '0.236';
  
  sub import {
      my $class = shift;
  
      my $inheritor = caller(0);
  
      if ( @_ and $_[0] eq '-norequire' ) {
          shift @_;
      } else {
          for ( my @filename = @_ ) {
              s{::|'}{/}g;
              require "$_.pm"; # dies if the file is not found
          }
      }
  
      {
          no strict 'refs';
          push @{"$inheritor\::ISA"}, @_; # dies if a loop is detected
      };
  };
  
  1;
  
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  parent - Establish an ISA relationship with base classes at compile time
  
  =head1 SYNOPSIS
  
      package Baz;
      use parent qw(Foo Bar);
  
  =head1 DESCRIPTION
  
  Allows you to both load one or more modules, while setting up inheritance from
  those modules at the same time.  Mostly similar in effect to
  
      package Baz;
      BEGIN {
          require Foo;
          require Bar;
          push @ISA, qw(Foo Bar);
      }
  
  By default, every base class needs to live in a file of its own.
  If you want to have a subclass and its parent class in the same file, you
  can tell C<parent> not to load any modules by using the C<-norequire> switch:
  
    package Foo;
    sub exclaim { "I CAN HAS PERL" }
  
    package DoesNotLoadFooBar;
    use parent -norequire, 'Foo', 'Bar';
    # will not go looking for Foo.pm or Bar.pm
  
  This is equivalent to the following code:
  
    package Foo;
    sub exclaim { "I CAN HAS PERL" }
  
    package DoesNotLoadFooBar;
    push @DoesNotLoadFooBar::ISA, 'Foo', 'Bar';
  
  This is also helpful for the case where a package lives within
  a differently named file:
  
    package MyHash;
    use Tie::Hash;
    use parent -norequire, 'Tie::StdHash';
  
  This is equivalent to the following code:
  
    package MyHash;
    require Tie::Hash;
    push @ISA, 'Tie::StdHash';
  
  If you want to load a subclass from a file that C<require> would
  not consider an eligible filename (that is, it does not end in
  either C<.pm> or C<.pmc>), use the following code:
  
    package MySecondPlugin;
    require './plugins/custom.plugin'; # contains Plugin::Custom
    use parent -norequire, 'Plugin::Custom';
  
  =head1 HISTORY
  
  This module was forked from L<base> to remove the cruft
  that had accumulated in it.
  
  =head1 CAVEATS
  
  =head1 SEE ALSO
  
  L<base>
  
  =head1 AUTHORS AND CONTRIBUTORS
  
  Rafaël Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern
  
  =head1 MAINTAINER
  
  Max Maischein C< corion@cpan.org >
  
  Copyright (c) 2007-10 Max Maischein C<< <corion@cpan.org> >>
  Based on the idea of C<base.pm>, which was introduced with Perl 5.004_04.
  
  =head1 LICENSE
  
  This module is released under the same terms as Perl itself.
  
  =cut
PARENT

$fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION';
  #!perl -w
  package version;
  
  use 5.006002;
  use strict;
  use warnings::register;
  if ($] >= 5.015) {
      warnings::register_categories(qw/version/);
  }
  
  our $VERSION = 0.9924;
  our $CLASS = 'version';
  our (@ISA, $STRICT, $LAX);
  
  # !!!!Delete this next block completely when adding to Perl core!!!!
  {
      local $SIG{'__DIE__'};
      if (1) { # always pretend there's no XS
  	eval "use version::vpp $VERSION"; # don't tempt fate
  	die "$@" if ( $@ );
  	push @ISA, "version::vpp";
  	local $^W;
  	*version::qv = \&version::vpp::qv;
  	*version::declare = \&version::vpp::declare;
  	*version::_VERSION = \&version::vpp::_VERSION;
  	*version::vcmp = \&version::vpp::vcmp;
  	*version::new = \&version::vpp::new;
  	*version::numify = \&version::vpp::numify;
  	*version::normal = \&version::vpp::normal;
  	if ($] >= 5.009000) {
  	    no strict 'refs';
  	    *version::stringify = \&version::vpp::stringify;
  	    *{'version::(""'} = \&version::vpp::stringify;
  	    *{'version::(<=>'} = \&version::vpp::vcmp;
  	    *{'version::(cmp'} = \&version::vpp::vcmp;
  	    *version::parse = \&version::vpp::parse;
  	}
      }
      else { # use XS module
  	push @ISA, "version::vxs";
  	local $^W;
  	*version::declare = \&version::vxs::declare;
  	*version::qv = \&version::vxs::qv;
  	*version::_VERSION = \&version::vxs::_VERSION;
  	*version::vcmp = \&version::vxs::VCMP;
  	*version::new = \&version::vxs::new;
  	*version::numify = \&version::vxs::numify;
  	*version::normal = \&version::vxs::normal;
  	if ($] >= 5.009000) {
  	    no strict 'refs';
  	    *version::stringify = \&version::vxs::stringify;
  	    *{'version::(""'} = \&version::vxs::stringify;
  	    *{'version::(<=>'} = \&version::vxs::VCMP;
  	    *{'version::(cmp'} = \&version::vxs::VCMP;
  	    *version::parse = \&version::vxs::parse;
  	}
      }
  }
  
  # avoid using Exporter
  require version::regex;
  *version::is_lax = \&version::regex::is_lax;
  *version::is_strict = \&version::regex::is_strict;
  *LAX = \$version::regex::LAX;
  *LAX_DECIMAL_VERSION = \$version::regex::LAX_DECIMAL_VERSION;
  *LAX_DOTTED_DECIMAL_VERSION = \$version::regex::LAX_DOTTED_DECIMAL_VERSION;
  *STRICT = \$version::regex::STRICT;
  *STRICT_DECIMAL_VERSION = \$version::regex::STRICT_DECIMAL_VERSION;
  *STRICT_DOTTED_DECIMAL_VERSION = \$version::regex::STRICT_DOTTED_DECIMAL_VERSION;
  
  sub import {
      no strict 'refs';
      my ($class) = shift;
  
      # Set up any derived class
      unless ($class eq $CLASS) {
  	local $^W;
  	*{$class.'::declare'} =  \&{$CLASS.'::declare'};
  	*{$class.'::qv'} = \&{$CLASS.'::qv'};
      }
  
      my %args;
      if (@_) { # any remaining terms are arguments
  	map { $args{$_} = 1 } @_
      }
      else { # no parameters at all on use line
  	%args =
  	(
  	    qv => 1,
  	    'UNIVERSAL::VERSION' => 1,
  	);
      }
  
      my $callpkg = caller();
  
      if (exists($args{declare})) {
  	*{$callpkg.'::declare'} =
  	    sub {return $class->declare(shift) }
  	  unless defined(&{$callpkg.'::declare'});
      }
  
      if (exists($args{qv})) {
  	*{$callpkg.'::qv'} =
  	    sub {return $class->qv(shift) }
  	  unless defined(&{$callpkg.'::qv'});
      }
  
      if (exists($args{'UNIVERSAL::VERSION'})) {
  	local $^W;
  	*UNIVERSAL::VERSION
  		= \&{$CLASS.'::_VERSION'};
      }
  
      if (exists($args{'VERSION'})) {
  	*{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
      }
  
      if (exists($args{'is_strict'})) {
  	*{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
  	  unless defined(&{$callpkg.'::is_strict'});
      }
  
      if (exists($args{'is_lax'})) {
  	*{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
  	  unless defined(&{$callpkg.'::is_lax'});
      }
  }
  
  
  1;
VERSION

$fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX';
  package version::regex;
  
  use strict;
  
  our $VERSION = 0.9924;
  
  #--------------------------------------------------------------------------#
  # Version regexp components
  #--------------------------------------------------------------------------#
  
  # Fraction part of a decimal version number.  This is a common part of
  # both strict and lax decimal versions
  
  my $FRACTION_PART = qr/\.[0-9]+/;
  
  # First part of either decimal or dotted-decimal strict version number.
  # Unsigned integer with no leading zeroes (except for zero itself) to
  # avoid confusion with octal.
  
  my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
  
  # First part of either decimal or dotted-decimal lax version number.
  # Unsigned integer, but allowing leading zeros.  Always interpreted
  # as decimal.  However, some forms of the resulting syntax give odd
  # results if used as ordinary Perl expressions, due to how perl treats
  # octals.  E.g.
  #   version->new("010" ) == 10
  #   version->new( 010  ) == 8
  #   version->new( 010.2) == 82  # "8" . "2"
  
  my $LAX_INTEGER_PART = qr/[0-9]+/;
  
  # Second and subsequent part of a strict dotted-decimal version number.
  # Leading zeroes are permitted, and the number is always decimal.
  # Limited to three digits to avoid overflow when converting to decimal
  # form and also avoid problematic style with excessive leading zeroes.
  
  my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
  
  # Second and subsequent part of a lax dotted-decimal version number.
  # Leading zeroes are permitted, and the number is always decimal.  No
  # limit on the numerical value or number of digits, so there is the
  # possibility of overflow when converting to decimal form.
  
  my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
  
  # Alpha suffix part of lax version number syntax.  Acts like a
  # dotted-decimal part.
  
  my $LAX_ALPHA_PART = qr/_[0-9]+/;
  
  #--------------------------------------------------------------------------#
  # Strict version regexp definitions
  #--------------------------------------------------------------------------#
  
  # Strict decimal version number.
  
  our $STRICT_DECIMAL_VERSION =
      qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
  
  # Strict dotted-decimal version number.  Must have both leading "v" and
  # at least three parts, to avoid confusion with decimal syntax.
  
  our $STRICT_DOTTED_DECIMAL_VERSION =
      qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
  
  # Complete strict version number syntax -- should generally be used
  # anchored: qr/ \A $STRICT \z /x
  
  our $STRICT =
      qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
  
  #--------------------------------------------------------------------------#
  # Lax version regexp definitions
  #--------------------------------------------------------------------------#
  
  # Lax decimal version number.  Just like the strict one except for
  # allowing an alpha suffix or allowing a leading or trailing
  # decimal-point
  
  our $LAX_DECIMAL_VERSION =
      qr/ $LAX_INTEGER_PART (?: $FRACTION_PART | \. )? $LAX_ALPHA_PART?
  	|
  	$FRACTION_PART $LAX_ALPHA_PART?
      /x;
  
  # Lax dotted-decimal version number.  Distinguished by having either
  # leading "v" or at least three non-alpha parts.  Alpha part is only
  # permitted if there are at least two non-alpha parts. Strangely
  # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
  # so when there is no "v", the leading part is optional
  
  our $LAX_DOTTED_DECIMAL_VERSION =
      qr/
  	v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
  	|
  	$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
      /x;
  
  # Complete lax version number syntax -- should generally be used
  # anchored: qr/ \A $LAX \z /x
  #
  # The string 'undef' is a special case to make for easier handling
  # of return values from ExtUtils::MM->parse_version
  
  our $LAX =
      qr/ undef | $LAX_DOTTED_DECIMAL_VERSION | $LAX_DECIMAL_VERSION /x;
  
  #--------------------------------------------------------------------------#
  
  # Preloaded methods go here.
  sub is_strict	{ defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
  sub is_lax	{ defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
  
  1;
VERSION_REGEX

$fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP';
  package charstar;
  # a little helper class to emulate C char* semantics in Perl
  # so that prescan_version can use the same code as in C
  
  use overload (
      '""'	=> \&thischar,
      '0+'	=> \&thischar,
      '++'	=> \&increment,
      '--'	=> \&decrement,
      '+'		=> \&plus,
      '-'		=> \&minus,
      '*'		=> \&multiply,
      'cmp'	=> \&cmp,
      '<=>'	=> \&spaceship,
      'bool'	=> \&thischar,
      '='		=> \&clone,
  );
  
  sub new {
      my ($self, $string) = @_;
      my $class = ref($self) || $self;
  
      my $obj = {
  	string  => [split(//,$string)],
  	current => 0,
      };
      return bless $obj, $class;
  }
  
  sub thischar {
      my ($self) = @_;
      my $last = $#{$self->{string}};
      my $curr = $self->{current};
      if ($curr >= 0 && $curr <= $last) {
  	return $self->{string}->[$curr];
      }
      else {
  	return '';
      }
  }
  
  sub increment {
      my ($self) = @_;
      $self->{current}++;
  }
  
  sub decrement {
      my ($self) = @_;
      $self->{current}--;
  }
  
  sub plus {
      my ($self, $offset) = @_;
      my $rself = $self->clone;
      $rself->{current} += $offset;
      return $rself;
  }
  
  sub minus {
      my ($self, $offset) = @_;
      my $rself = $self->clone;
      $rself->{current} -= $offset;
      return $rself;
  }
  
  sub multiply {
      my ($left, $right, $swapped) = @_;
      my $char = $left->thischar();
      return $char * $right;
  }
  
  sub spaceship {
      my ($left, $right, $swapped) = @_;
      unless (ref($right)) { # not an object already
  	$right = $left->new($right);
      }
      return $left->{current} <=> $right->{current};
  }
  
  sub cmp {
      my ($left, $right, $swapped) = @_;
      unless (ref($right)) { # not an object already
  	if (length($right) == 1) { # comparing single character only
  	    return $left->thischar cmp $right;
  	}
  	$right = $left->new($right);
      }
      return $left->currstr cmp $right->currstr;
  }
  
  sub bool {
      my ($self) = @_;
      my $char = $self->thischar;
      return ($char ne '');
  }
  
  sub clone {
      my ($left, $right, $swapped) = @_;
      $right = {
  	string  => [@{$left->{string}}],
  	current => $left->{current},
      };
      return bless $right, ref($left);
  }
  
  sub currstr {
      my ($self, $s) = @_;
      my $curr = $self->{current};
      my $last = $#{$self->{string}};
      if (defined($s) && $s->{current} < $last) {
  	$last = $s->{current};
      }
  
      my $string = join('', @{$self->{string}}[$curr..$last]);
      return $string;
  }
  
  package version::vpp;
  
  use 5.006002;
  use strict;
  use warnings::register;
  
  use Config;
  
  our $VERSION = 0.9924;
  our $CLASS = 'version::vpp';
  our ($LAX, $STRICT, $WARN_CATEGORY);
  
  if ($] > 5.015) {
      warnings::register_categories(qw/version/);
      $WARN_CATEGORY = 'version';
  } else {
      $WARN_CATEGORY = 'numeric';
  }
  
  require version::regex;
  *version::vpp::is_strict = \&version::regex::is_strict;
  *version::vpp::is_lax = \&version::regex::is_lax;
  *LAX = \$version::regex::LAX;
  *STRICT = \$version::regex::STRICT;
  
  use overload (
      '""'       => \&stringify,
      '0+'       => \&numify,
      'cmp'      => \&vcmp,
      '<=>'      => \&vcmp,
      'bool'     => \&vbool,
      '+'        => \&vnoop,
      '-'        => \&vnoop,
      '*'        => \&vnoop,
      '/'        => \&vnoop,
      '+='        => \&vnoop,
      '-='        => \&vnoop,
      '*='        => \&vnoop,
      '/='        => \&vnoop,
      'abs'      => \&vnoop,
  );
  
  sub import {
      no strict 'refs';
      my ($class) = shift;
  
      # Set up any derived class
      unless ($class eq $CLASS) {
  	local $^W;
  	*{$class.'::declare'} =  \&{$CLASS.'::declare'};
  	*{$class.'::qv'} = \&{$CLASS.'::qv'};
      }
  
      my %args;
      if (@_) { # any remaining terms are arguments
  	map { $args{$_} = 1 } @_
      }
      else { # no parameters at all on use line
  	%args =
  	(
  	    qv => 1,
  	    'UNIVERSAL::VERSION' => 1,
  	);
      }
  
      my $callpkg = caller();
  
      if (exists($args{declare})) {
  	*{$callpkg.'::declare'} =
  	    sub {return $class->declare(shift) }
  	  unless defined(&{$callpkg.'::declare'});
      }
  
      if (exists($args{qv})) {
  	*{$callpkg.'::qv'} =
  	    sub {return $class->qv(shift) }
  	  unless defined(&{$callpkg.'::qv'});
      }
  
      if (exists($args{'UNIVERSAL::VERSION'})) {
  	no warnings qw/redefine/;
  	*UNIVERSAL::VERSION
  		= \&{$CLASS.'::_VERSION'};
      }
  
      if (exists($args{'VERSION'})) {
  	*{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
      }
  
      if (exists($args{'is_strict'})) {
  	*{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
  	  unless defined(&{$callpkg.'::is_strict'});
      }
  
      if (exists($args{'is_lax'})) {
  	*{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
  	  unless defined(&{$callpkg.'::is_lax'});
      }
  }
  
  my $VERSION_MAX = 0x7FFFFFFF;
  
  # implement prescan_version as closely to the C version as possible
  use constant TRUE  => 1;
  use constant FALSE => 0;
  
  sub isDIGIT {
      my ($char) = shift->thischar();
      return ($char =~ /\d/);
  }
  
  sub isALPHA {
      my ($char) = shift->thischar();
      return ($char =~ /[a-zA-Z]/);
  }
  
  sub isSPACE {
      my ($char) = shift->thischar();
      return ($char =~ /\s/);
  }
  
  sub BADVERSION {
      my ($s, $errstr, $error) = @_;
      if ($errstr) {
  	$$errstr = $error;
      }
      return $s;
  }
  
  sub prescan_version {
      my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
      my $qv          = defined $sqv          ? $$sqv          : FALSE;
      my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
      my $width       = defined $swidth       ? $$swidth       : 3;
      my $alpha       = defined $salpha       ? $$salpha       : FALSE;
  
      my $d = $s;
  
      if ($qv && isDIGIT($d)) {
  	goto dotted_decimal_version;
      }
  
      if ($d eq 'v') { # explicit v-string
  	$d++;
  	if (isDIGIT($d)) {
  	    $qv = TRUE;
  	}
  	else { # degenerate v-string
  	    # requires v1.2.3
  	    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  	}
  
  dotted_decimal_version:
  	if ($strict && $d eq '0' && isDIGIT($d+1)) {
  	    # no leading zeros allowed
  	    return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
  	}
  
  	while (isDIGIT($d)) { 	# integer part
  	    $d++;
  	}
  
  	if ($d eq '.')
  	{
  	    $saw_decimal++;
  	    $d++; 		# decimal point
  	}
  	else
  	{
  	    if ($strict) {
  		# require v1.2.3
  		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  	    }
  	    else {
  		goto version_prescan_finish;
  	    }
  	}
  
  	{
  	    my $i = 0;
  	    my $j = 0;
  	    while (isDIGIT($d)) {	# just keep reading
  		$i++;
  		while (isDIGIT($d)) {
  		    $d++; $j++;
  		    # maximum 3 digits between decimal
  		    if ($strict && $j > 3) {
  			return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
  		    }
  		}
  		if ($d eq '_') {
  		    if ($strict) {
  			return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
  		    }
  		    if ( $alpha ) {
  			return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
  		    }
  		    $d++;
  		    $alpha = TRUE;
  		}
  		elsif ($d eq '.') {
  		    if ($alpha) {
  			return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
  		    }
  		    $saw_decimal++;
  		    $d++;
  		}
  		elsif (!isDIGIT($d)) {
  		    last;
  		}
  		$j = 0;
  	    }
  
  	    if ($strict && $i < 2) {
  		# requires v1.2.3
  		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  	    }
  	}
      } 					# end if dotted-decimal
      else
      {					# decimal versions
  	my $j = 0;
  	# special $strict case for leading '.' or '0'
  	if ($strict) {
  	    if ($d eq '.') {
  		return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
  	    }
  	    if ($d eq '0' && isDIGIT($d+1)) {
  		return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
  	    }
  	}
  
  	# and we never support negative version numbers
  	if ($d eq '-') {
  	    return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
  	}
  
  	# consume all of the integer part
  	while (isDIGIT($d)) {
  	    $d++;
  	}
  
  	# look for a fractional part
  	if ($d eq '.') {
  	    # we found it, so consume it
  	    $saw_decimal++;
  	    $d++;
  	}
  	elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
  	    if ( $d == $s ) {
  		# found nothing
  		return BADVERSION($s,$errstr,"Invalid version format (version required)");
  	    }
  	    # found just an integer
  	    goto version_prescan_finish;
  	}
  	elsif ( $d == $s ) {
  	    # didn't find either integer or period
  	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
  	}
  	elsif ($d eq '_') {
  	    # underscore can't come after integer part
  	    if ($strict) {
  		return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
  	    }
  	    elsif (isDIGIT($d+1)) {
  		return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
  	    }
  	    else {
  		return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
  	    }
  	}
  	elsif ($d) {
  	    # anything else after integer part is just invalid data
  	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
  	}
  
  	# scan the fractional part after the decimal point
  	if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
  		# $strict or lax-but-not-the-end
  		return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
  	}
  
  	while (isDIGIT($d)) {
  	    $d++; $j++;
  	    if ($d eq '.' && isDIGIT($d-1)) {
  		if ($alpha) {
  		    return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
  		}
  		if ($strict) {
  		    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
  		}
  		$d = $s; # start all over again
  		$qv = TRUE;
  		goto dotted_decimal_version;
  	    }
  	    if ($d eq '_') {
  		if ($strict) {
  		    return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
  		}
  		if ( $alpha ) {
  		    return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
  		}
  		if ( ! isDIGIT($d+1) ) {
  		    return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
  		}
  		$width = $j;
  		$d++;
  		$alpha = TRUE;
  	    }
  	}
      }
  
  version_prescan_finish:
      while (isSPACE($d)) {
  	$d++;
      }
  
      if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
  	# trailing non-numeric data
  	return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
      }
      if ($saw_decimal > 1 && ($d-1) eq '.') {
  	# no trailing period allowed
  	return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)");
      }
  
      if (defined $sqv) {
  	$$sqv = $qv;
      }
      if (defined $swidth) {
  	$$swidth = $width;
      }
      if (defined $ssaw_decimal) {
  	$$ssaw_decimal = $saw_decimal;
      }
      if (defined $salpha) {
  	$$salpha = $alpha;
      }
      return $d;
  }
  
  sub scan_version {
      my ($s, $rv, $qv) = @_;
      my $start;
      my $pos;
      my $last;
      my $errstr;
      my $saw_decimal = 0;
      my $width = 3;
      my $alpha = FALSE;
      my $vinf = FALSE;
      my @av;
  
      $s = new charstar $s;
  
      while (isSPACE($s)) { # leading whitespace is OK
  	$s++;
      }
  
      $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
  	\$width, \$alpha);
  
      if ($errstr) {
  	# 'undef' is a special case and not an error
  	if ( $s ne 'undef') {
  	    require Carp;
  	    Carp::croak($errstr);
  	}
      }
  
      $start = $s;
      if ($s eq 'v') {
  	$s++;
      }
      $pos = $s;
  
      if ( $qv ) {
  	$$rv->{qv} = $qv;
      }
      if ( $alpha ) {
  	$$rv->{alpha} = $alpha;
      }
      if ( !$qv && $width < 3 ) {
  	$$rv->{width} = $width;
      }
  
      while (isDIGIT($pos) || $pos eq '_') {
  	$pos++;
      }
      if (!isALPHA($pos)) {
  	my $rev;
  
  	for (;;) {
  	    $rev = 0;
  	    {
    		# this is atoi() that delimits on underscores
    		my $end = $pos;
    		my $mult = 1;
  		my $orev;
  
  		#  the following if() will only be true after the decimal
  		#  point of a version originally created with a bare
  		#  floating point number, i.e. not quoted in any way
  		#
   		if ( !$qv && $s > $start && $saw_decimal == 1 ) {
  		    $mult *= 100;
   		    while ( $s < $end ) {
  			next if $s eq '_';
  			$orev = $rev;
   			$rev += $s * $mult;
   			$mult /= 10;
  			if (   (abs($orev) > abs($rev))
  			    || (abs($rev) > $VERSION_MAX )) {
  			    warn("Integer overflow in version %d",
  					   $VERSION_MAX);
  			    $s = $end - 1;
  			    $rev = $VERSION_MAX;
  			    $vinf = 1;
  			}
   			$s++;
  			if ( $s eq '_' ) {
  			    $s++;
  			}
   		    }
    		}
   		else {
   		    while (--$end >= $s) {
  			next if $end eq '_';
  			$orev = $rev;
   			$rev += $end * $mult;
   			$mult *= 10;
  			if (   (abs($orev) > abs($rev))
  			    || (abs($rev) > $VERSION_MAX )) {
  			    warn("Integer overflow in version");
  			    $end = $s - 1;
  			    $rev = $VERSION_MAX;
  			    $vinf = 1;
  			}
   		    }
   		}
    	    }
  
    	    # Append revision
  	    push @av, $rev;
  	    if ( $vinf ) {
  		$s = $last;
  		last;
  	    }
  	    elsif ( $pos eq '.' ) {
  		$s = ++$pos;
  	    }
  	    elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
  		$s = ++$pos;
  	    }
  	    elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
  		$s = ++$pos;
  	    }
  	    elsif ( isDIGIT($pos) ) {
  		$s = $pos;
  	    }
  	    else {
  		$s = $pos;
  		last;
  	    }
  	    if ( $qv ) {
  		while ( isDIGIT($pos) || $pos eq '_') {
  		    $pos++;
  		}
  	    }
  	    else {
  		my $digits = 0;
  		while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
  		    if ( $pos ne '_' ) {
  			$digits++;
  		    }
  		    $pos++;
  		}
  	    }
  	}
      }
      if ( $qv ) { # quoted versions always get at least three terms
  	my $len = $#av;
  	#  This for loop appears to trigger a compiler bug on OS X, as it
  	#  loops infinitely. Yes, len is negative. No, it makes no sense.
  	#  Compiler in question is:
  	#  gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
  	#  for ( len = 2 - len; len > 0; len-- )
  	#  av_push(MUTABLE_AV(sv), newSViv(0));
  	#
  	$len = 2 - $len;
  	while ($len-- > 0) {
  	    push @av, 0;
  	}
      }
  
      # need to save off the current version string for later
      if ( $vinf ) {
  	$$rv->{original} = "v.Inf";
  	$$rv->{vinf} = 1;
      }
      elsif ( $s > $start ) {
  	$$rv->{original} = $start->currstr($s);
  	if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
  	    # need to insert a v to be consistent
  	    $$rv->{original} = 'v' . $$rv->{original};
  	}
      }
      else {
  	$$rv->{original} = '0';
  	push(@av, 0);
      }
  
      # And finally, store the AV in the hash
      $$rv->{version} = \@av;
  
      # fix RT#19517 - special case 'undef' as string
      if ($s eq 'undef') {
  	$s += 5;
      }
  
      return $s;
  }
  
  sub new {
      my $class = shift;
      unless (defined $class or $#_ > 1) {
  	require Carp;
  	Carp::croak('Usage: version::new(class, version)');
      }
  
      my $self = bless ({}, ref ($class) || $class);
      my $qv = FALSE;
  
      if ( $#_ == 1 ) { # must be CVS-style
  	$qv = TRUE;
      }
      my $value = pop; # always going to be the last element
  
      if ( ref($value) && eval('$value->isa("version")') ) {
  	# Can copy the elements directly
  	$self->{version} = [ @{$value->{version} } ];
  	$self->{qv} = 1 if $value->{qv};
  	$self->{alpha} = 1 if $value->{alpha};
  	$self->{original} = ''.$value->{original};
  	return $self;
      }
  
      if ( not defined $value or $value =~ /^undef$/ ) {
  	# RT #19517 - special case for undef comparison
  	# or someone forgot to pass a value
  	push @{$self->{version}}, 0;
  	$self->{original} = "0";
  	return ($self);
      }
  
  
      if (ref($value) =~ m/ARRAY|HASH/) {
  	require Carp;
  	Carp::croak("Invalid version format (non-numeric data)");
      }
  
      $value = _un_vstring($value);
  
      if ($Config{d_setlocale}) {
  	use POSIX qw/locale_h/;
  	use if $Config{d_setlocale}, 'locale';
  	my $currlocale = setlocale(LC_ALL);
  
  	# if the current locale uses commas for decimal points, we
  	# just replace commas with decimal places, rather than changing
  	# locales
  	if ( localeconv()->{decimal_point} eq ',' ) {
  	    $value =~ tr/,/./;
  	}
      }
  
      # exponential notation
      if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
  	$value = sprintf("%.9f",$value);
  	$value =~ s/(0+)$//; # trim trailing zeros
      }
  
      my $s = scan_version($value, \$self, $qv);
  
      if ($s) { # must be something left over
  	warn(sprintf "Version string '%s' contains invalid data; "
  		   ."ignoring: '%s'", $value, $s);
      }
  
      return ($self);
  }
  
  *parse = \&new;
  
  sub numify {
      my ($self) = @_;
      unless (_verify($self)) {
  	require Carp;
  	Carp::croak("Invalid version object");
      }
      my $alpha = $self->{alpha} || "";
      my $len = $#{$self->{version}};
      my $digit = $self->{version}[0];
      my $string = sprintf("%d.", $digit );
  
      if ($alpha and warnings::enabled()) {
  	warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy');
      }
  
      for ( my $i = 1 ; $i <= $len ; $i++ ) {
  	$digit = $self->{version}[$i];
  	$string .= sprintf("%03d", $digit);
      }
  
      if ( $len == 0 ) {
  	$string .= sprintf("000");
      }
  
      return $string;
  }
  
  sub normal {
      my ($self) = @_;
      unless (_verify($self)) {
  	require Carp;
  	Carp::croak("Invalid version object");
      }
  
      my $len = $#{$self->{version}};
      my $digit = $self->{version}[0];
      my $string = sprintf("v%d", $digit );
  
      for ( my $i = 1 ; $i <= $len ; $i++ ) {
  	$digit = $self->{version}[$i];
  	$string .= sprintf(".%d", $digit);
      }
  
      if ( $len <= 2 ) {
  	for ( $len = 2 - $len; $len != 0; $len-- ) {
  	    $string .= sprintf(".%0d", 0);
  	}
      }
  
      return $string;
  }
  
  sub stringify {
      my ($self) = @_;
      unless (_verify($self)) {
  	require Carp;
  	Carp::croak("Invalid version object");
      }
      return exists $self->{original}
      	? $self->{original}
  	: exists $self->{qv}
  	    ? $self->normal
  	    : $self->numify;
  }
  
  sub vcmp {
      my ($left,$right,$swap) = @_;
      my $class = ref($left);
      unless ( UNIVERSAL::isa($right, $class) ) {
  	$right = $class->new($right);
      }
  
      if ( $swap ) {
  	($left, $right) = ($right, $left);
      }
      unless (_verify($left)) {
  	require Carp;
  	Carp::croak("Invalid version object");
      }
      unless (_verify($right)) {
  	require Carp;
  	Carp::croak("Invalid version format");
      }
      my $l = $#{$left->{version}};
      my $r = $#{$right->{version}};
      my $m = $l < $r ? $l : $r;
      my $lalpha = $left->is_alpha;
      my $ralpha = $right->is_alpha;
      my $retval = 0;
      my $i = 0;
      while ( $i <= $m && $retval == 0 ) {
  	$retval = $left->{version}[$i] <=> $right->{version}[$i];
  	$i++;
      }
  
      # possible match except for trailing 0's
      if ( $retval == 0 && $l != $r ) {
  	if ( $l < $r ) {
  	    while ( $i <= $r && $retval == 0 ) {
  		if ( $right->{version}[$i] != 0 ) {
  		    $retval = -1; # not a match after all
  		}
  		$i++;
  	    }
  	}
  	else {
  	    while ( $i <= $l && $retval == 0 ) {
  		if ( $left->{version}[$i] != 0 ) {
  		    $retval = +1; # not a match after all
  		}
  		$i++;
  	    }
  	}
      }
  
      return $retval;
  }
  
  sub vbool {
      my ($self) = @_;
      return vcmp($self,$self->new("0"),1);
  }
  
  sub vnoop {
      require Carp;
      Carp::croak("operation not supported with version object");
  }
  
  sub is_alpha {
      my ($self) = @_;
      return (exists $self->{alpha});
  }
  
  sub qv {
      my $value = shift;
      my $class = $CLASS;
      if (@_) {
  	$class = ref($value) || $value;
  	$value = shift;
      }
  
      $value = _un_vstring($value);
      $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
      my $obj = $CLASS->new($value);
      return bless $obj, $class;
  }
  
  *declare = \&qv;
  
  sub is_qv {
      my ($self) = @_;
      return (exists $self->{qv});
  }
  
  
  sub _verify {
      my ($self) = @_;
      if ( ref($self)
  	&& eval { exists $self->{version} }
  	&& ref($self->{version}) eq 'ARRAY'
  	) {
  	return 1;
      }
      else {
  	return 0;
      }
  }
  
  sub _is_non_alphanumeric {
      my $s = shift;
      $s = new charstar $s;
      while ($s) {
  	return 0 if isSPACE($s); # early out
  	return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
  	$s++;
      }
      return 0;
  }
  
  sub _un_vstring {
      my $value = shift;
      # may be a v-string
      if ( length($value) >= 1 && $value !~ /[,._]/
  	&& _is_non_alphanumeric($value)) {
  	my $tvalue;
  	if ( $] >= 5.008_001 ) {
  	    $tvalue = _find_magic_vstring($value);
  	    $value = $tvalue if length $tvalue;
  	}
  	elsif ( $] >= 5.006_000 ) {
  	    $tvalue = sprintf("v%vd",$value);
  	    if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) {
  		# must be a v-string
  		$value = $tvalue;
  	    }
  	}
      }
      return $value;
  }
  
  sub _find_magic_vstring {
      my $value = shift;
      my $tvalue = '';
      require B;
      my $sv = B::svref_2object(\$value);
      my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
      while ( $magic ) {
  	if ( $magic->TYPE eq 'V' ) {
  	    $tvalue = $magic->PTR;
  	    $tvalue =~ s/^v?(.+)$/v$1/;
  	    last;
  	}
  	else {
  	    $magic = $magic->MOREMAGIC;
  	}
      }
      $tvalue =~ tr/_//d;
      return $tvalue;
  }
  
  sub _VERSION {
      my ($obj, $req) = @_;
      my $class = ref($obj) || $obj;
  
      no strict 'refs';
      if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
  	 # file but no package
  	require Carp;
  	Carp::croak( "$class defines neither package nor VERSION"
  	    ."--version check failed");
      }
  
      my $version = eval "\$$class\::VERSION";
      if ( defined $version ) {
  	local $^W if $] <= 5.008;
  	$version = version::vpp->new($version);
      }
  
      if ( defined $req ) {
  	unless ( defined $version ) {
  	    require Carp;
  	    my $msg =  $] < 5.006
  	    ? "$class version $req required--this is only version "
  	    : "$class does not define \$$class\::VERSION"
  	      ."--version check failed";
  
  	    if ( $ENV{VERSION_DEBUG} ) {
  		Carp::confess($msg);
  	    }
  	    else {
  		Carp::croak($msg);
  	    }
  	}
  
  	$req = version::vpp->new($req);
  
  	if ( $req > $version ) {
  	    require Carp;
  	    if ( $req->is_qv ) {
  		Carp::croak(
  		    sprintf ("%s version %s required--".
  			"this is only version %s", $class,
  			$req->normal, $version->normal)
  		);
  	    }
  	    else {
  		Carp::croak(
  		    sprintf ("%s version %s required--".
  			"this is only version %s", $class,
  			$req->stringify, $version->stringify)
  		);
  	    }
  	}
      }
  
      return defined $version ? $version->stringify : undef;
  }
  
  1; #this line is important and will help the module return a true value
VERSION_VPP

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



use strict;
use Menlo::CLI::Compat;

unless (caller) {
    my $app = Menlo::CLI::Compat->new;
    $app->parse_options(@ARGV);
    $app->run;
    exit $app->status;
}

__END__

=head1 NAME

cpanm - get, unpack build and install modules from CPAN

=head1 SYNOPSIS

  cpanm Test::More                                 # install Test::More
  cpanm MIYAGAWA/Plack-0.99_05.tar.gz              # full distribution path
  cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz  # install from URL
  cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz   # install from a local file
  cpanm --interactive Task::Kensho                 # Configure interactively
  cpanm .                                          # install from local directory
  cpanm --installdeps .                            # install all the deps for the current directory
  cpanm -L extlib Plack                            # install Plack and all non-core deps into extlib
  cpanm --mirror http://cpan.cpantesters.org/ DBI  # use the fast-syncing mirror
  cpanm --from https://cpan.metacpan.org/ Plack    # use only the HTTPS mirror

=head1 COMMANDS

=over 4

=item (arguments)

Command line arguments can be either a module name, distribution file,
local file path, HTTP URL or git repository URL. Following commands
will all work as you expect.

    cpanm Plack
    cpanm Plack/Request.pm
    cpanm MIYAGAWA/Plack-1.0000.tar.gz
    cpanm /path/to/Plack-1.0000.tar.gz
    cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz
    cpanm git://github.com/plack/Plack.git

Additionally, you can use the notation using C<~> and C<@> to specify
version for a given module. C<~> specifies the version requirement in
the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and
is a shortcut for C<~"== VERSION">.

    cpanm Plack~1.0000                 # 1.0000 or later
    cpanm Plack~">= 1.0000, < 2.0000"  # latest of 1.xxxx
    cpanm Plack@0.9990                 # specific version. same as Plack~"== 0.9990"

The version query including specific version or range will be sent to
L<MetaCPAN> to search for previous releases. The query will search for
BackPAN archives by default, unless you specify C<--dev> option, in
which case, archived versions will be filtered out.

For a git repository, you can specify a branch, tag, or commit SHA to
build. The default is C<master>

    cpanm git://github.com/plack/Plack.git@1.0000        # tag
    cpanm git://github.com/plack/Plack.git@devel         # branch

=item -i, --install

Installs the modules. This is a default behavior and this is just a
compatibility option to make it work like L<cpan> or L<cpanp>.

=item --self-upgrade

Upgrades itself. It's just an alias for:

  cpanm App::cpanminus

=item --info

Displays the distribution information in
C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out.

=item --installdeps

Installs the dependencies of the target distribution but won't build
itself. Handy if you want to try the application from a version
controlled repository such as git.

  cpanm --installdeps .

=item --look

Download and unpack the distribution and then open the directory with
your shell. Handy to poke around the source code or do manual
testing.

=item -h, --help

Displays the help message.

=item -V, --version

Displays the version number.

=back

=head1 OPTIONS

You can specify the default options in C<PERL_CPANM_OPT> environment variable.

=over 4

=item -f, --force

Force install modules even when testing failed.

=item -n, --notest

Skip the testing of modules. Use this only when you just want to save
time for installing hundreds of distributions to the same perl and
architecture you've already tested to make sure it builds fine.

Defaults to false, and you can say C<--no-notest> to override when it
is set in the default options in C<PERL_CPANM_OPT>.

=item --test-only

Run the tests only, and do not install the specified module or
distributions. Handy if you want to verify the new (or even old)
releases pass its unit tests without installing the module.

Note that if you specify this option with a module or distribution
that has dependencies, these dependencies will be installed if you
don't currently have them.

=item -S, --sudo

Switch to the root user with C<sudo> when installing modules. Use this
if you want to install modules to the system perl include path.

Defaults to false, and you can say C<--no-sudo> to override when it is
set in the default options in C<PERL_CPANM_OPT>.

=item -v, --verbose

Makes the output verbose. It also enables the interactive
configuration. (See --interactive)

=item -q, --quiet

Makes the output even more quiet than the default. It only shows the
successful/failed dependencies to the output.

=item -l, --local-lib

Sets the L<local::lib> compatible path to install modules to. You
don't need to set this if you already configure the shell environment
variables using L<local::lib>, but this can be used to override that
as well.

=item -L, --local-lib-contained

Same with C<--local-lib> but with L<--self-contained> set.  All
non-core dependencies will be installed even if they're already
installed.

For instance,

  cpanm -L extlib Plack

would install Plack and all of its non-core dependencies into the
directory C<extlib>, which can be loaded from your application with:

  use local::lib '/path/to/extlib';

Note that this option does B<NOT> reliably work with perl installations
supplied by operating system vendors that strips standard modules from perl,
such as RHEL, Fedora and CentOS, B<UNLESS> you also install packages supplying
all the modules that have been stripped.  For these systems you will probably
want to install the C<perl-core> meta-package which does just that.

=item --self-contained

When examining the dependencies, assume no non-core modules are
installed on the system. Handy if you want to bundle application
dependencies in one directory so you can distribute to other machines.

=item --exclude-vendor

Don't include modules installed under the 'vendor' paths when searching for
core modules when the C<--self-contained> flag is in effect.  This restores
the behaviour from before version 1.7023

=item --mirror

Specifies the base URL for the CPAN mirror to use, such as
C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You
can specify multiple mirror URLs by repeating the command line option.

You can use a local directory that has a CPAN mirror structure
(created by tools such as L<OrePAN> or L<Pinto>) by using a special
URL scheme C<file://>. If the given URL begins with `/` (without any
scheme), it is considered as a file scheme as well.

  cpanm --mirror file:///path/to/mirror
  cpanm --mirror ~/minicpan      # Because shell expands ~ to /home/user

Defaults to C<http://www.cpan.org/>.

=item --mirror-only

Download the mirror's 02packages.details.txt.gz index file instead of
querying the CPAN Meta DB. This will also effectively opt out sending
your local perl versions to backend database servers such as CPAN Meta
DB and MetaCPAN.

Select this option if you are using a local mirror of CPAN, such as
minicpan when you're offline, or your own CPAN index (a.k.a darkpan).

=item --from, -M

  cpanm -M https://cpan.metacpan.org/
  cpanm --from https://cpan.metacpan.org/

Use the given mirror URL and its index as the I<only> source to search
and download modules from.

It works similar to C<--mirror> and C<--mirror-only> combined, with a
small difference: unlike C<--mirror> which I<appends> the URL to the
list of mirrors, C<--from> (or C<-M> for short) uses the specified URL
as its I<only> source to download index and modules from. This makes
the option always override the default mirror, which might have been
set via global options such as the one set by C<PERL_CPANM_OPT>
environment variable.

B<Tip:> It might be useful if you name these options with your shell
aliases, like:

  alias minicpanm='cpanm --from ~/minicpan'
  alias darkpan='cpanm --from http://mycompany.example.com/DPAN'

=item --mirror-index

B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt>
for module search index.

=item --cpanmetadb

B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups.

=item --metacpan

Prefers MetaCPAN API over CPAN MetaDB.

=item --cpanfile

B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for,
when C<--installdeps> command is in use. Defaults to C<cpanfile>.

=item --prompt

Prompts when a test fails so that you can skip, force install, retry
or look in the shell to see what's going wrong. It also prompts when
one of the dependency failed if you want to proceed the installation.

Defaults to false, and you can say C<--no-prompt> to override if it's
set in the default options in C<PERL_CPANM_OPT>.

=item --dev

B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false.

=item --reinstall

cpanm, when given a module name in the command line (i.e. C<cpanm
Plack>), checks the locally installed version first and skips if it is
already installed. This option makes it skip the check, so:

  cpanm --reinstall Plack

would reinstall L<Plack> even if your locally installed version is
latest, or even newer (which would happen if you install a developer
release from version control repositories).

Defaults to false.

=item --interactive

Makes the configuration (such as C<Makefile.PL> and C<Build.PL>)
interactive, so you can answer questions in the distribution that
requires custom configuration or Task:: distributions.

Defaults to false, and you can say C<--no-interactive> to override
when it's set in the default options in C<PERL_CPANM_OPT>.

=item --pp, --pureperl

Prefer Pure perl build of modules by setting C<PUREPERL_ONLY=1> for
MakeMaker and C<--pureperl-only> for Build.PL based
distributions. Note that not all of the CPAN modules support this
convention yet.

=item --with-recommends, --with-suggests

B<EXPERIMENTAL>: Installs dependencies declared as C<recommends> and
C<suggests> respectively, per META spec. When these dependencies fail
to install, cpanm continues the installation, since they're just
recommendation/suggestion.

Enabling this could potentially make a circular dependency for a few
modules on CPAN, when C<recommends> adds a module that C<recommends>
back the module in return.

There's also C<--without-recommend> and C<--without-suggests> to
override the default decision made earlier in C<PERL_CPANM_OPT>.

Defaults to false for both.

=item --with-develop

B<EXPERIMENTAL>: Installs develop phase dependencies in META files or
C<cpanfile> when used with C<--installdeps>. Defaults to false.

=item --with-configure

B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile>
when used with C<--installdeps>. Defaults to false.

=item --with-feature, --without-feature, --with-all-features

B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports
optional features per META spec 2.0.

    cpanm --with-feature=opt_csv Spreadsheet::Read

the features can also be interactively chosen when C<--interactive>
option is enabled.

C<--with-all-features> enables all the optional features, and
C<--without-feature> can select a feature to disable.

=item --configure-timeout, --build-timeout, --test-timeout

Specify the timeout length (in seconds) to wait for the configure,
build and test process. Current default values are: 60 for configure,
3600 for build and 1800 for test.

=item --configure-args, --build-args, --test-args, --install-args

B<EXPERIMENTAL>: Pass arguments for configure/build/test/install
commands respectively, for a given module to install.

    cpanm DBD::mysql --configure-args="--cflags=... --libs=..."

The argument is only enabled for the module passed as a command line
argument, not dependencies.

=item --scandeps

B<DEPRECATED>: Scans the depencencies of given modules and output the
tree in a text format. (See C<--format> below for more options)

Because this command doesn't actually install any distributions, it
will be useful that by typing:

  cpanm --scandeps Catalyst::Runtime

you can make sure what modules will be installed.

This command takes into account which modules you already have
installed in your system. If you want to see what modules will be
installed against a vanilla perl installation, you might want to
combine it with C<-L> option.

=item --format

B<DEPRECATED>: Determines what format to display the scanned
dependency tree. Available options are C<tree>, C<json>, C<yaml> and
C<dists>.

=over 8

=item tree

Displays the tree in a plain text format. This is the default value.

=item json, yaml

Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules
need to be installed respectively. The output tree is represented as a
recursive tuple of:

  [ distribution, dependencies ]

and the container is an array containing the root elements. Note that
there may be multiple root nodes, since you can give multiple modules
to the C<--scandeps> command.

=item dists

C<dists> is a special output format, where it prints the distribution
filename in the I<depth first order> after the dependency resolution,
like:

  GAAS/MIME-Base64-3.13.tar.gz
  GAAS/URI-1.58.tar.gz
  PETDANCE/HTML-Tagset-3.20.tar.gz
  GAAS/HTML-Parser-3.68.tar.gz
  GAAS/libwww-perl-5.837.tar.gz

which means you can install these distributions in this order without
extra dependencies. When combined with C<-L> option, it will be useful
to replay installations on other machines.

=back

=item --save-dists

Specifies the optional directory path to copy downloaded tarballs in
the CPAN mirror compatible directory structure
i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz>

If the distro tarball did not come from CPAN, for example from a local
file or from GitHub, then it will be saved under
I<vendor/Foo-Bar-version.tar.gz>.

=item --uninst-shadows

Uninstalls the shadow files of the distribution that you're
installing. This eliminates the confusion if you're trying to install
core (dual-life) modules from CPAN against perl 5.10 or older, or
modules that used to be XS-based but switched to pure perl at some
version.

If you run cpanm as root and use C<INSTALL_BASE> or equivalent to
specify custom installation path, you SHOULD disable this option so
you won't accidentally uninstall dual-life modules from the core
include path.

Defaults to true if your perl version is smaller than 5.12, and you
can disable that with C<--no-uninst-shadows>.

B<NOTE>: Since version 1.3000 this flag is turned off by default for
perl newer than 5.12, since with 5.12 @INC contains site_perl directory
I<before> the perl core library path, and uninstalling shadows is not
necessary anymore and does more harm by deleting files from the core
library path.

=item --uninstall, -U

Uninstalls a module from the library path. It finds a packlist for
given modules, and removes all the files included in the same
distribution.

If you enable local::lib, it only removes files from the local::lib
directory.

If you try to uninstall a module in C<perl> directory (i.e. core
module), an error will be thrown.

A dialog will be prompted to confirm the files to be deleted. If you pass
C<-f> option as well, the dialog will be skipped and uninstallation
will be forced.

=item --cascade-search

B<EXPERIMENTAL>: Specifies whether to cascade search when you specify
multiple mirrors and a mirror doesn't have a module or has a lower
version of the module than requested. Defaults to false.

=item --skip-installed

Specifies whether a module given in the command line is skipped if its latest
version is already installed. Defaults to true.

B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set
for this to work with modules installed using L<local::lib>, unless
you always use the C<-l> option.

=item --skip-satisfied

B<EXPERIMENTAL>: Specifies whether a module (and version) given in the
command line is skipped if it's already installed.

If you run:

  cpanm --skip-satisfied CGI DBI~1.2

cpanm won't install them if you already have CGI (for whatever
versions) or have DBI with version higher than 1.2. It is similar to
C<--skip-installed> but while C<--skip-installed> checks if the
I<latest> version of CPAN is installed, C<--skip-satisfied> checks if
a requested version (or not, which means any version) is installed.

Defaults to false.

=item --verify

Verify the integrity of distribution files retrieved from PAUSE using
CHECKSUMS and SIGNATURES (if found). Defaults to false.

=item --report-perl-version

Whether it reports the locally installed perl version to the various
web server as part of User-Agent. Defaults to true unless CI related
environment variables such as C<TRAVIS>, C<CI> or C<AUTOMATED_TESTING>
is enabled. You can disable it by using C<--no-report-perl-version>.

=item --auto-cleanup

Specifies the number of days in which cpanm's work directories
expire. Defaults to 7, which means old work directories will be
cleaned up in one week.

You can set the value to C<0> to make cpan never cleanup those
directories.

=item --man-pages

Generates man pages for executables (man1) and libraries (man3).

Defaults to true (man pages generated) unless C<-L|--local-lib-contained>
option is supplied in which case it's set to false. You can disable
it with C<--no-man-pages>.

=item --lwp

Uses L<LWP> module to download stuff over HTTP. Defaults to true, and
you can say C<--no-lwp> to disable using LWP, when you want to upgrade
LWP from CPAN on some broken perl systems.

=item --wget

Uses GNU Wget (if available) to download stuff. Defaults to true, and
you can say C<--no-wget> to disable using Wget (versions of Wget older
than 1.9 don't support the C<--retry-connrefused> option used by cpanm).

=item --curl

Uses cURL (if available) to download stuff. Defaults to true, and
you can say C<--no-curl> to disable using cURL.

Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
(which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny>
(in that order) and uses the first one available.

=back

=head1 ENVIRONMENT VARIABLES

=over 4

=item PERL_CPANM_HOME

The directory cpanm should use to store downloads and build and test
modules. Defaults to the C<.cpanm> directory in your user's home
directory.

=item PERL_CPANM_OPT

If set, adds a set of default options to every cpanm command. These
options come first, and so are overridden by command-line options.

=back

=head1 SEE ALSO

L<App::cpanminus>

=head1 COPYRIGHT

Copyright 2010- Tatsuhiko Miyagawa.

=head1 AUTHOR

Tatsuhiko Miyagawa

=cut
