#!/usr/bin/env perl

# 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{"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/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK';
  package CPAN::Meta::Check;
  # vi:noet:sts=2:sw=2:ts=2
  $CPAN::Meta::Check::VERSION = '0.018';
  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) = @_;
  
  	return $reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module) if $module eq 'perl';
  
  	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.018
  
  =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>
  
  =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{"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.50';
  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.50
  
  =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("err.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 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 Ed Sabol fecundf Graham Knop Karen Etheridge Mohammad S Anwar Peter Rabbitson Sven Kirmess
  
  =over 4
  
  =item *
  
  Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
  
  =item *
  
  David E. Wheeler <david@justatheory.com>
  
  =item *
  
  Ed Sabol <esabol@users.noreply.github.com>
  
  =item *
  
  fecundf <not.com+github@gmail.com>
  
  =item *
  
  Graham Knop <haarg@haarg.org>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Mohammad S Anwar <mohammad.anwar@yahoo.com>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =item *
  
  Sven Kirmess <sven.kirmess@kzone.ch>
  
  =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{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
  package Carton;
  use strict;
  use 5.008_005;
  use version; our $VERSION = version->declare("v1.0.35");
  
  1;
  __END__
  
  =head1 NAME
  
  Carton - Perl module dependency manager (aka Bundler for Perl)
  
  =head1 SYNOPSIS
  
    # On your development environment
    > cat cpanfile
    requires 'Plack', '0.9980';
    requires 'Starman', '0.2000';
  
    > carton install
    > git add cpanfile cpanfile.snapshot
    > git commit -m "add Plack and Starman"
  
    # Other developer's machine, or on a deployment box
    > carton install
    > carton exec starman -p 8080 myapp.psgi
  
    # carton exec is optional
    > perl -Ilocal/lib/perl5 local/bin/starman -p 8080 myapp.psgi
    > PERL5LIB=/path/to/local/lib/perl5 /path/to/local/bin/starman -p 8080 myapp.psgi
  
  =head1 AVAILABILITY
  
  Carton only works with perl installation with the complete set of core
  modules. If you use perl installed by a vendor package with modules
  stripped from core, Carton is not expected to work correctly.
  
  Also, Carton requires you to run your command/application with
  C<carton exec> command or to include the I<local/lib/perl5> directory
  in your Perl library search path (using C<PERL5LIB>, C<-I>, or
  L<lib>).
  
  =head1 DESCRIPTION
  
  carton is a command line tool to track the Perl module dependencies
  for your Perl application. Dependencies are declared using L<cpanfile>
  format, and the managed dependencies are tracked in a
  I<cpanfile.snapshot> file, which is meant to be version controlled,
  and the snapshot file allows other developers of your application will
  have the exact same versions of the modules.
  
  For C<cpanfile> syntax, see L<cpanfile> documentation.
  
  =head1 TUTORIAL
  
  =head2 Initializing the environment
  
  carton will use the I<local> directory to install modules into. You're
  recommended to exclude these directories from the version control
  system.
  
    > echo local/ >> .gitignore
    > git add cpanfile cpanfile.snapshot
    > git commit -m "Start using carton"
  
  =head2 Tracking the dependencies
  
  You can manage the dependencies of your application via C<cpanfile>.
  
    # cpanfile
    requires 'Plack', '0.9980';
    requires 'Starman', '0.2000';
  
  And then you can install these dependencies via:
  
    > carton install
  
  The modules are installed into your I<local> directory, and the
  dependencies tree and version information are analyzed and saved into
  I<cpanfile.snapshot> in your directory.
  
  Make sure you add I<cpanfile> and I<cpanfile.snapshot> to your version
  controlled repository and commit changes as you update
  dependencies. This will ensure that other developers on your app, as
  well as your deployment environment, use exactly the same versions of
  the modules you just installed.
  
    > git add cpanfile cpanfile.snapshot
    > git commit -m "Added Plack and Starman"
  
  =head2 Specifying a CPAN distribution
  
  You can pin a module resolution to a specific distribution using a
  combination of C<dist>, C<mirror> and C<url> options in C<cpanfile>.
  
    # specific distribution on PAUSE
    requires 'Plack', '== 0.9980',
      dist => 'MIYAGAWA/Plack-0.9980.tar.gz';
  
    # local mirror (darkpan)
    requires 'Plack', '== 0.9981',
      dist => 'MYCOMPANY/Plack-0.9981-p1.tar.gz',
      mirror => 'https://pause.local/';
  
    # URL
    requires 'Plack', '== 1.1000',
      url => 'https://pause.local/authors/id/M/MY/MYCOMPANY/Plack-1.1000.tar.gz';
  
  =head2 Deploying your application
  
  Once you've done installing all the dependencies, you can push your
  application directory to a remote machine (excluding I<local> and
  I<.carton>) and run the following command:
  
    > carton install --deployment
  
  This will look at the I<cpanfile.snapshot> and install the exact same
  versions of the dependencies into I<local>, and now your application
  is ready to run.
  
  The C<--deployment> flag makes sure that carton will only install
  modules and versions available in your snapshot, and won't fallback to
  query for CPAN Meta DB for missing modules.
  
  =head2 Bundling modules
  
  carton can bundle all the tarballs for your dependencies into a
  directory so that you can even install dependencies that are not
  available on CPAN, such as internal distribution aka DarkPAN.
  
    > carton bundle
  
  will bundle these tarballs into I<vendor/cache> directory, and
  
    > carton install --cached
  
  will install modules using this local cache. Combined with
  C<--deployment> option, you can avoid querying for a database like
  CPAN Meta DB or downloading files from CPAN mirrors upon deployment
  time.
  
  As of Carton v1.0.32, the bundle also includes a package index
  allowing you to simply use L<cpanm> (which has a
  L<standalone version|App::cpanminus/"Downloading the standalone executable">)
  instead of installing Carton on a remote machine.
  
    > cpanm -L local --from "$PWD/vendor/cache" --installdeps --notest --quiet .
  
  =head1 PERL VERSIONS
  
  When you take a snapshot in one perl version and deploy on another
  (different) version, you might have troubles with core modules.
  
  The simplest solution, which might not work for everybody, is to use
  the same version of perl in the development and deployment.
  
  To enforce that, you're recommended to use L<plenv> and
  C<.perl-version> to lock perl versions in development.
  
  You can also specify the minimum perl required in C<cpanfile>:
  
    requires 'perl', '5.16.3';
  
  and carton (and cpanm) will give you errors when deployed on hosts
  with perl lower than the specified version.
  
  =head1 COMMUNITY
  
  =over 4
  
  =item L<https://github.com/perl-carton/carton>
  
  Code repository, Wiki and Issue Tracker
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 COPYRIGHT
  
  Tatsuhiko Miyagawa 2011-
  
  =head1 LICENSE
  
  This software is licensed under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<Carmel>
  
  L<cpanm>
  
  L<cpanfile>
  
  L<Bundler|http://gembundler.com/>
  
  L<pip|http://pypi.python.org/pypi/pip>
  
  L<npm|http://npmjs.org/>
  
  L<perlrocks|https://github.com/gugod/perlrocks>
  
  L<only>
  
  =cut
CARTON

$fatpacked{"Carton/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_BUILDER';
  package Carton::Builder;
  use strict;
  use Class::Tiny {
      mirror => undef,
      index  => undef,
      cascade => sub { 1 },
      without => sub { [] },
      cpanfile => undef,
  };
  
  sub effective_mirrors {
      my $self = shift;
  
      # push default CPAN mirror always, as a fallback
      # TODO don't pass fallback if --cached is set?
  
      my @mirrors = ($self->mirror);
      push @mirrors, Carton::Mirror->default if $self->custom_mirror;

      # Hotpatch by the OTOBO Team 2025-12-15.
      # Do not fall back to installing from the BackPan.
      #push @mirrors, Carton::Mirror->new('http://backpan.perl.org/');
  
      @mirrors;
  }
  
  sub custom_mirror {
      my $self = shift;
      ! $self->mirror->is_default;
  }
  
  sub bundle {
      my($self, $path, $cache_path, $snapshot) = @_;
  
      for my $dist ($snapshot->distributions) {
          my $source = $path->child("cache/authors/id/" . $dist->pathname);
          my $target = $cache_path->child("authors/id/" . $dist->pathname);
  
          if ($source->exists) {
              warn "Copying ", $dist->pathname, "\n";
              $target->parent->mkpath;
              $source->copy($target) or warn "$target: $!";
          } else {
              warn "Couldn't find @{[ $dist->pathname ]}\n";
          }
      }
  
      my $has_io_gzip = eval { require IO::Compress::Gzip; 1 };
  
      my $ext   = $has_io_gzip ? ".txt.gz" : ".txt";
      my $index = $cache_path->child("modules/02packages.details$ext");
      $index->parent->mkpath;
  
      warn "Writing $index\n";
  
      my $out = $index->openw;
      if ($has_io_gzip) {
          $out = IO::Compress::Gzip->new($out)
            or die "gzip failed: $IO::Compress::Gzip::GzipError";
      }
  
      $snapshot->index->write($out);
      close $out;
  
      unless ($has_io_gzip) {
          unlink "$index.gz";
          !system 'gzip', $index
            or die "Running gzip command failed: $!";
      }
  }
  
  sub install {
      my($self, $path) = @_;
  
      $self->run_install(
          "-L", $path,
          (map { ("--mirror", $_->url) } $self->effective_mirrors),
          ( $self->index ? ("--mirror-index", $self->index) : () ),
          ( $self->cascade ? "--cascade-search" : () ),
          ( $self->custom_mirror ? "--mirror-only" : () ),
          "--save-dists", "$path/cache",
          $self->groups,
          "--cpanfile", $self->cpanfile,
          "--installdeps", $self->cpanfile->dirname,
      ) or die "Installing modules failed\n";
  }
  
  sub groups {
      my $self = shift;
  
      # TODO support --without test (don't need test on deployment)
      my @options = ('--with-all-features', '--with-develop');
  
      for my $group (@{$self->without}) {
          push @options, '--without-develop' if $group eq 'develop';
          push @options, "--without-feature=$group";
      }
  
      return @options;
  }
  
  sub update {
      my($self, $path, @modules) = @_;
  
      $self->run_install(
          "-L", $path,
          (map { ("--mirror", $_->url) } $self->effective_mirrors),
          ( $self->custom_mirror ? "--mirror-only" : () ),
          "--save-dists", "$path/cache",
          @modules
      ) or die "Updating modules failed\n";
  }
  
  sub run_install {
      my($self, @args) = @_;
  
      require Menlo::CLI::Compat;
      local $ENV{PERL_CPANM_OPT};
  
      my $cli = Menlo::CLI::Compat->new;
      $cli->parse_options("--quiet", "--notest", @args);
      $cli->run;
  
      !$cli->status;
  }
  
  1;
CARTON_BUILDER

$fatpacked{"Carton/CLI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_CLI';
  package Carton::CLI;
  use strict;
  use warnings;
  use Config;
  use Getopt::Long;
  use Path::Tiny;
  use Try::Tiny;
  use Module::CoreList;
  use Scalar::Util qw(blessed);
  
  use Carton;
  use Carton::Builder;
  use Carton::Mirror;
  use Carton::Snapshot;
  use Carton::Util;
  use Carton::Environment;
  use Carton::Error;
  
  use constant { SUCCESS => 0, INFO => 1, WARN => 2, ERROR => 3 };
  
  our $UseSystem = 0; # 1 for unit testing
  
  use Class::Tiny {
      verbose => undef,
      carton => sub { $_[0]->_build_carton },
      mirror => sub { $_[0]->_build_mirror },
  };
  
  sub _build_mirror {
      my $self = shift;
      Carton::Mirror->new($ENV{PERL_CARTON_MIRROR} || $Carton::Mirror::DefaultMirror);
  }
  
  sub run {
      my($self, @args) = @_;
  
      my @commands;
      my $p = Getopt::Long::Parser->new(
          config => [ "no_ignore_case", "pass_through" ],
      );
      $p->getoptionsfromarray(
          \@args,
          "h|help"    => sub { unshift @commands, 'help' },
          "v|version" => sub { unshift @commands, 'version' },
          "verbose!"  => sub { $self->verbose($_[1]) },
      );
  
      push @commands, @args;
  
      my $cmd = shift @commands || 'install';
  
      my $code = try {
          my $call = $self->can("cmd_$cmd")
              or Carton::Error::CommandNotFound->throw(error => "Could not find command '$cmd'");
          $self->$call(@commands);
          return 0;
      } catch {
          die $_ unless blessed $_ && $_->can('rethrow');
  
          if ($_->isa('Carton::Error::CommandExit')) {
              return $_->code || 255;
          } elsif ($_->isa('Carton::Error::CommandNotFound')) {
              warn $_->error, "\n\n";
              $self->cmd_usage;
              return 255;
          } elsif ($_->isa('Carton::Error')) {
              warn $_->error, "\n";
              return 255;
          }
      };
  
      return $code;
  }
  
  sub commands {
      my $self = shift;
  
      no strict 'refs';
      map { s/^cmd_//; $_ }
          grep { /^cmd_.*/ && $self->can($_) } sort keys %{__PACKAGE__."::"};
  }
  
  sub cmd_usage {
      my $self = shift;
      $self->print(<<HELP);
  Usage: carton <command>
  
  where <command> is one of:
    @{[ join ", ", $self->commands ]}
  
  Run carton -h <command> for help.
  HELP
  }
  
  sub parse_options {
      my($self, $args, @spec) = @_;
      my $p = Getopt::Long::Parser->new(
          config => [ "no_auto_abbrev", "no_ignore_case" ],
      );
      $p->getoptionsfromarray($args, @spec);
  }
  
  sub parse_options_pass_through {
      my($self, $args, @spec) = @_;
  
      my $p = Getopt::Long::Parser->new(
          config => [ "no_auto_abbrev", "no_ignore_case", "pass_through" ],
      );
      $p->getoptionsfromarray($args, @spec);
  
      # with pass_through keeps -- in args
      shift @$args if $args->[0] && $args->[0] eq '--';
  }
  
  sub printf {
      my $self = shift;
      my $type = pop;
      my($temp, @args) = @_;
      $self->print(sprintf($temp, @args), $type);
  }
  
  sub print {
      my($self, $msg, $type) = @_;
      my $fh = $type && $type >= WARN ? *STDERR : *STDOUT;
      print {$fh} $msg;
  }
  
  sub error {
      my($self, $msg) = @_;
      $self->print($msg, ERROR);
      Carton::Error::CommandExit->throw;
  }
  
  sub cmd_help {
      my $self = shift;
      my $module = $_[0] ? ("Carton::Doc::" . ucfirst $_[0]) : "Carton.pm";
      system "perldoc", $module;
  }
  
  sub cmd_version {
      my $self = shift;
      $self->print("carton $Carton::VERSION\n");
  }
  
  sub cmd_bundle {
      my($self, @args) = @_;
  
      my $env = Carton::Environment->build;
      $env->snapshot->load;
  
      $self->print("Bundling modules using @{[$env->cpanfile]}\n");
  
      my $builder = Carton::Builder->new(
          mirror => $self->mirror,
          cpanfile => $env->cpanfile,
      );
      $builder->bundle($env->install_path, $env->vendor_cache, $env->snapshot);
  
      $self->printf("Complete! Modules were bundled into %s\n", $env->vendor_cache, SUCCESS);
  }
  
  sub cmd_fatpack {
      my($self, @args) = @_;
  
      my $env = Carton::Environment->build;
      require Carton::Packer;
      Carton::Packer->new->fatpack_carton($env->vendor_bin);
  }
  
  sub cmd_install {
      my($self, @args) = @_;
  
      my($install_path, $cpanfile_path, @without);
  
      $self->parse_options(
          \@args,
          "p|path=s"    => \$install_path,
          "cpanfile=s"  => \$cpanfile_path,
          "without=s"   => sub { push @without, split /,/, $_[1] },
          "deployment!" => \my $deployment,
          "cached!"     => \my $cached,
      );
  
      my $env = Carton::Environment->build($cpanfile_path, $install_path);
      $env->snapshot->load_if_exists;
  
      if ($deployment && !$env->snapshot->loaded) {
          $self->error("--deployment requires cpanfile.snapshot: Run `carton install` and make sure cpanfile.snapshot is checked into your version control.\n");
      }
  
      my $builder = Carton::Builder->new(
          cascade => 1,
          mirror  => $self->mirror,
          without => \@without,
          cpanfile => $env->cpanfile,
      );
  
      # TODO: --without with no .lock won't fetch the groups, resulting in insufficient requirements
  
      if ($deployment) {
          $self->print("Installing modules using @{[$env->cpanfile]} (deployment mode)\n");
          $builder->cascade(0);
      } else {
          $self->print("Installing modules using @{[$env->cpanfile]}\n");
      }
  
      # TODO merge CPANfile git to mirror even if lock doesn't exist
      if ($env->snapshot->loaded) {
          my $index_file = $env->install_path->child("cache/modules/02packages.details.txt");
             $index_file->parent->mkpath;
  
          $env->snapshot->write_index($index_file);
          $builder->index($index_file);
      }
  
      if ($cached) {
          $builder->mirror(Carton::Mirror->new($env->vendor_cache));
      }
  
      $builder->install($env->install_path);
  
      unless ($deployment) {
          $env->cpanfile->load;
          $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements);
          $env->snapshot->save;
      }
  
      $self->print("Complete! Modules were installed into @{[$env->install_path]}\n", SUCCESS);
  }
  
  sub cmd_show {
      my($self, @args) = @_;
  
      my $env = Carton::Environment->build;
      $env->snapshot->load;
  
      for my $module (@args) {
          my $dist = $env->snapshot->find($module)
              or $self->error("Couldn't locate $module in cpanfile.snapshot\n");
          $self->print( $dist->name . "\n" );
      }
  }
  
  sub cmd_list {
      my($self, @args) = @_;
  
      my $format = 'name';
  
      $self->parse_options(
          \@args,
          "distfile" => sub { $format = 'distfile' },
      );
  
      my $env = Carton::Environment->build;
      $env->snapshot->load;
  
      for my $dist ($env->snapshot->distributions) {
          $self->print($dist->$format . "\n");
      }
  }
  
  sub cmd_tree {
      my($self, @args) = @_;
  
      my $env = Carton::Environment->build;
      $env->snapshot->load;
      $env->cpanfile->load;
  
      my %seen;
      my $dumper = sub {
          my($dependency, $reqs, $level) = @_;
          return if $level == 0;
          return Carton::Tree::STOP if $dependency->dist->is_core;
          return Carton::Tree::STOP if $seen{$dependency->distname}++;
          $self->printf( "%s%s (%s)\n", " " x ($level - 1), $dependency->module, $dependency->distname, INFO );
      };
  
      $env->tree->walk_down($dumper);
  }
  
  sub cmd_check {
      my($self, @args) = @_;
  
      my $cpanfile_path;
      $self->parse_options(
          \@args,
          "cpanfile=s"  => \$cpanfile_path,
      );
  
      my $env = Carton::Environment->build($cpanfile_path);
      $env->snapshot->load;
      $env->cpanfile->load;
  
      # TODO remove snapshot
      # TODO pass git spec to Requirements?
      my $merged_reqs = $env->tree->merged_requirements;
  
      my @missing;
      for my $module ($merged_reqs->required_modules) {
          my $install = $env->snapshot->find_or_core($module);
          if ($install) {
              unless ($merged_reqs->accepts_module($module => $install->version_for($module))) {
                  push @missing, [ $module, 1, $install->version_for($module) ];
              }
          } else {
              push @missing, [ $module, 0 ];
          }
      }
  
      if (@missing) {
          $self->print("Following dependencies are not satisfied.\n", INFO);
          for my $missing (@missing) {
              my($module, $unsatisfied, $version) = @$missing;
              if ($unsatisfied) {
                  $self->printf("  %s has version %s. Needs %s\n",
                                $module, $version, $merged_reqs->requirements_for_module($module), INFO);
              } else {
                  $self->printf("  %s is not installed. Needs %s\n",
                                $module, $merged_reqs->requirements_for_module($module), INFO);
              }
          }
          $self->printf("Run `carton install` to install them.\n", INFO);
          Carton::Error::CommandExit->throw;
      } else {
          $self->print("cpanfile's dependencies are satisfied.\n", INFO);
      }
  }
  
  sub cmd_update {
      my($self, @args) = @_;
  
      my $env = Carton::Environment->build;
      $env->cpanfile->load;
  
  
      my $cpanfile = Module::CPANfile->load($env->cpanfile);
      @args = grep { $_ ne 'perl' } $env->cpanfile->required_modules unless @args;
  
      $env->snapshot->load;
  
      my @modules;
      for my $module (@args) {
          my $dist = $env->snapshot->find_or_core($module)
              or $self->error("Could not find module $module.\n");
          next if $dist->is_core;
          push @modules, "$module~" . $env->cpanfile->requirements_for_module($module);
      }
  
      return unless @modules;
  
      my $builder = Carton::Builder->new(
          mirror => $self->mirror,
          cpanfile => $env->cpanfile,
      );
      $builder->update($env->install_path, @modules);
  
      $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements);
      $env->snapshot->save;
  }
  
  sub cmd_run {
      my($self, @args) = @_;
  
      local $UseSystem = 1;
      $self->cmd_exec(@args);
  }
  
  sub cmd_exec {
      my($self, @args) = @_;
  
      my $env = Carton::Environment->build;
      $env->snapshot->load;
  
      # allows -Ilib
      @args = map { /^(-[I])(.+)/ ? ($1,$2) : $_ } @args;
  
      while (@args) {
          if ($args[0] eq '-I') {
              warn "exec -Ilib is deprecated. You might want to run: carton exec perl -Ilib ...\n";
              splice(@args, 0, 2);
          } else {
              last;
          }
      }
  
      $self->parse_options_pass_through(\@args); # to handle --
  
      unless (@args) {
          $self->error("carton exec needs a command to run.\n");
      }
  
      # PERL5LIB takes care of arch
      my $path = $env->install_path;
      local $ENV{PERL5LIB} = "$path/lib/perl5";
      local $ENV{PATH} = "$path/bin:$ENV{PATH}";
  
      if ($UseSystem) {
          system @args;
      } else {
          exec @args;
          exit 127; # command not found
      }
  }
  
  1;
CARTON_CLI

$fatpacked{"Carton/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_CPANFILE';
  package Carton::CPANfile;
  use Path::Tiny ();
  use Module::CPANfile;
  
  use overload q{""} => sub { $_[0]->stringify }, fallback => 1;
  
  use subs 'path';
  
  use Class::Tiny {
      path => undef,
      _cpanfile => undef,
      requirements => sub { $_[0]->_build_requirements },
  };
  
  sub stringify { shift->path->stringify(@_) }
  sub dirname   { shift->path->dirname(@_) }
  sub prereqs   { shift->_cpanfile->prereqs(@_) }
  sub required_modules { shift->requirements->required_modules(@_) }
  sub requirements_for_module { shift->requirements->requirements_for_module(@_) }
  
  sub path {
      my $self = shift;
      if (@_) {
          $self->{path} = Path::Tiny->new($_[0]);
      } else {
          $self->{path};
      }
  }
  
  sub load {
      my $self = shift;
      $self->_cpanfile( Module::CPANfile->load($self->path) );
  }
  
  sub _build_requirements {
      my $self = shift;
      my $reqs = CPAN::Meta::Requirements->new;
      $reqs->add_requirements($self->prereqs->requirements_for($_, 'requires'))
          for qw( configure build runtime test develop );
      $reqs->clear_requirement('perl');
      $reqs;
  }
  
  1;
CARTON_CPANFILE

$fatpacked{"Carton/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_DEPENDENCY';
  package Carton::Dependency;
  use strict;
  use Class::Tiny {
      module => undef,
      requirement => undef,
      dist => undef,
  };
  
  sub requirements { shift->dist->requirements(@_) }
  
  sub distname {
      my $self = shift;
      $self->dist->name;
  }
  
  sub version {
      my $self = shift;
      $self->dist->version_for($self->module);
  }
  
  1;
CARTON_DEPENDENCY

$fatpacked{"Carton/Dist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_DIST';
  package Carton::Dist;
  use strict;
  use Class::Tiny {
      name => undef,
      pathname => undef,
      provides => sub { +{} },
      requirements => sub { $_[0]->_build_requirements },
  };
  
  use CPAN::Meta;
  
  sub add_string_requirement  { shift->requirements->add_string_requirement(@_) }
  sub required_modules        { shift->requirements->required_modules(@_) }
  sub requirements_for_module { shift->requirements->requirements_for_module(@_) }
  
  sub is_core { 0 }
  
  sub distfile {
      my $self = shift;
      $self->pathname;
  }
  
  sub _build_requirements {
      CPAN::Meta::Requirements->new;
  }
  
  sub provides_module {
      my($self, $module) = @_;
      exists $self->provides->{$module};
  }
  
  sub version_for {
      my($self, $module) = @_;
      $self->provides->{$module}{version};
  }
  
  1;
CARTON_DIST

$fatpacked{"Carton/Dist/Core.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_DIST_CORE';
  package Carton::Dist::Core;
  use strict;
  use parent 'Carton::Dist';
  
  use Class::Tiny qw( module_version );
  
  sub BUILDARGS {
      my($class, %args) = @_;
  
      # TODO represent dual-life
      $args{name} =~ s/::/-/g;
  
      \%args;
  }
  
  sub is_core { 1 }
  
  sub version_for {
      my($self, $module) = @_;
      $self->module_version;
  }
  
  1;
CARTON_DIST_CORE

$fatpacked{"Carton/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_ENVIRONMENT';
  package Carton::Environment;
  use strict;
  use Carton::CPANfile;
  use Carton::Snapshot;
  use Carton::Error;
  use Carton::Tree;
  use Path::Tiny;
  
  use Class::Tiny {
      cpanfile => undef,
      snapshot => sub { $_[0]->_build_snapshot },
      install_path => sub { $_[0]->_build_install_path },
      vendor_cache => sub { $_[0]->_build_vendor_cache },
      tree => sub { $_[0]->_build_tree },
  };
  
  sub _build_snapshot {
      my $self = shift;
      Carton::Snapshot->new(path => $self->cpanfile . ".snapshot");
  }
  
  sub _build_install_path {
      my $self = shift;
      if ($ENV{PERL_CARTON_PATH}) {
          return Path::Tiny->new($ENV{PERL_CARTON_PATH});
      } else {
          return $self->cpanfile->path->parent->child("local");
      }
  }
  
  sub _build_vendor_cache {
      my $self = shift;
      Path::Tiny->new($self->install_path->dirname . "/vendor/cache");
  }
  
  sub _build_tree {
      my $self = shift;
      Carton::Tree->new(cpanfile => $self->cpanfile, snapshot => $self->snapshot);
  }
  
  sub vendor_bin {
      my $self = shift;
      $self->vendor_cache->parent->child('bin');
  }
  
  sub build_with {
      my($class, $cpanfile) = @_;
  
      $cpanfile = Path::Tiny->new($cpanfile)->absolute;
      if ($cpanfile->is_file) {
          return $class->new(cpanfile => Carton::CPANfile->new(path => $cpanfile));
      } else {
          Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: $cpanfile");
      }
  }
  
  sub build {
      my($class, $cpanfile_path, $install_path) = @_;
  
      my $self = $class->new;
  
      $cpanfile_path &&= Path::Tiny->new($cpanfile_path)->absolute;
  
      my $cpanfile = $self->locate_cpanfile($cpanfile_path || $ENV{PERL_CARTON_CPANFILE});
      if ($cpanfile && $cpanfile->is_file) {
          $self->cpanfile( Carton::CPANfile->new(path => $cpanfile) );
      } else {
          Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: (@{[ $cpanfile_path || 'cpanfile' ]})");
      }
  
      $self->install_path( Path::Tiny->new($install_path)->absolute ) if $install_path;
  
      $self;
  }
  
  sub locate_cpanfile {
      my($self, $path) = @_;
  
      if ($path) {
          return Path::Tiny->new($path)->absolute;
      }
  
      my $current  = Path::Tiny->cwd;
      my $previous = '';
  
      until ($current eq '/' or $current eq $previous) {
          # TODO support PERL_CARTON_CPANFILE
          my $try = $current->child('cpanfile');
          if ($try->is_file) {
              return $try->absolute;
          }
  
          ($previous, $current) = ($current, $current->parent);
      }
  
      return;
  }
  
  1;
  
CARTON_ENVIRONMENT

$fatpacked{"Carton/Error.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_ERROR';
  package Carton::Error;
  use strict;
  use overload '""' => sub { $_[0]->error };
  use Carp;
  
  sub throw {
      my($class, @args) = @_;
      die $class->new(@args);
  }
  
  sub rethrow {
      die $_[0];
  }
  
  sub new {
      my($class, %args) = @_;
      bless \%args, $class;
  }
  
  sub error {
      $_[0]->{error} || ref $_[0];
  }
  
  package Carton::Error::CommandNotFound;
  use parent 'Carton::Error';
  
  package Carton::Error::CommandExit;
  use parent 'Carton::Error';
  sub code { $_[0]->{code} }
  
  package Carton::Error::CPANfileNotFound;
  use parent 'Carton::Error';
  
  package Carton::Error::SnapshotParseError;
  use parent 'Carton::Error';
  sub path { $_[0]->{path} }
  
  package Carton::Error::SnapshotNotFound;
  use parent 'Carton::Error';
  sub path { $_[0]->{path} }
  
  1;
CARTON_ERROR

$fatpacked{"Carton/Index.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_INDEX';
  package Carton::Index;
  use strict;
  use Class::Tiny {
      _packages => sub { +{} },
      generator => sub { require Carton; "Carton $Carton::VERSION" },
  };
  
  sub add_package {
      my($self, $package) = @_;
      $self->_packages->{$package->name} = $package; # XXX ||=
  }
  
  sub count {
      my $self = shift;
      scalar keys %{$self->_packages};
  }
  
  sub packages {
      my $self = shift;
      sort { lc $a->name cmp lc $b->name } values %{$self->_packages};
  }
  
  sub write {
      my($self, $fh) = @_;
  
      print $fh <<EOF;
  File:         02packages.details.txt
  URL:          http://www.perl.com/CPAN/modules/02packages.details.txt
  Description:  Package names found in cpanfile.snapshot
  Columns:      package name, version, path
  Intended-For: Automated fetch routines, namespace documentation.
  Written-By:   @{[ $self->generator ]}
  Line-Count:   @{[ $self->count ]}
  Last-Updated: @{[ scalar localtime ]}
  
  EOF
      for my $p ($self->packages) {
          print $fh $self->_format_line($p->name, $p->version_format, $p->pathname);
      }
  }
  
  sub _format_line {
      my($self, @row) = @_;
  
      # from PAUSE::mldistwatch::rewrite02
      my $one = 30;
      my $two = 8;
  
      if (length $row[0] > $one) {
          $one += 8 - length $row[1];
          $two = length $row[1];
      }
  
      sprintf "%-${one}s %${two}s  %s\n", @row;
  }
  
  sub pad {
      my($str, $len, $left) = @_;
  
      my $howmany = $len - length($str);
      return $str if $howmany <= 0;
  
      my $pad = " " x $howmany;
      return $left ? "$pad$str" : "$str$pad";
  }
  
  
  1;
CARTON_INDEX

$fatpacked{"Carton/Mirror.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_MIRROR';
  package Carton::Mirror;
  use strict;
  use Class::Tiny qw( url );
  
  # Hotpatch by the OTOBO Team 2025-12-15.
  # Fetch the distributions via HTTPS
  #our $DefaultMirror = 'http://cpan.metacpan.org/';
  our $DefaultMirror = 'https://cpan.metacpan.org/';
  
  sub BUILDARGS {
      my($class, $url) = @_;
      return { url => $url };
  }
  
  sub default {
      my $class = shift;
      $class->new($DefaultMirror);
  }
  
  sub is_default {
      my $self = shift;
      $self->url eq $DefaultMirror;
  }
  
  1;
  
CARTON_MIRROR

$fatpacked{"Carton/Package.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_PACKAGE';
  package Carton::Package;
  use strict;
  use Class::Tiny qw( name version pathname );
  
  sub BUILDARGS {
      my($class, @args) = @_;
      return { name => $args[0], version => $args[1], pathname => $args[2] };
  }
  
  sub version_format {
      my $self = shift;
      defined $self->version ? $self->version : 'undef';
  }
  
  1;
  
  
CARTON_PACKAGE

$fatpacked{"Carton/Packer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_PACKER';
  package Carton::Packer;
  use Class::Tiny;
  use warnings NONFATAL => 'all';
  use App::FatPacker;
  use File::pushd ();
  use Path::Tiny ();
  use CPAN::Meta ();
  use File::Find ();
  
  sub fatpack_carton {
      my($self, $dir) = @_;
  
      my $temp = Path::Tiny->tempdir;
      my $pushd = File::pushd::pushd $temp;
  
      my $file = $temp->child('carton.pre.pl');
  
      $file->spew(<<'EOF');
  #!/usr/bin/env perl
  use strict;
  use 5.008001;
  use Carton::CLI;
  $Carton::Fatpacked = 1;
  exit Carton::CLI->new->run(@ARGV);
  EOF
  
      my $fatpacked = $self->do_fatpack($file);
  
      my $executable = $dir->child('carton');
      warn "Bundling $executable\n";
  
      $dir->mkpath;
      $executable->spew($fatpacked);
      chmod 0755, $executable;
  }
  
  sub do_fatpack {
      my($self, $file) = @_;
  
      my $packer = App::FatPacker->new;
  
      my @modules = split /\r?\n/, $packer->trace(args => [$file], use => $self->required_modules);
      my @packlists = $packer->packlists_containing(\@modules);
      $packer->packlists_to_tree(Path::Tiny->new('fatlib')->absolute, \@packlists);
  
      my $fatpacked = do {
          local $SIG{__WARN__} = sub {};
          $packer->fatpack_file($file);
      };
  
      # HACK: File::Spec bundled into arch in < 5.16, but is loadable as pure-perl
      use Config;
      $fatpacked =~ s/\$fatpacked\{"$Config{archname}\/(Cwd|File)/\$fatpacked{"$1/g;
  
      $fatpacked;
  }
  
  sub required_modules {
      my $self = shift;
  
      my %requirements;
      for my $dist (qw( Carton Menlo-Legacy Menlo )) {
          $requirements{$_} = 1 for $self->required_modules_for($dist);
      }
  
      # these modules are needed, but lazy-loaded, so FatPacker wont bundle them by default.
      my @extra = qw(Menlo::Index::Mirror);
  
      [ keys %requirements, @extra ];
  }
  
  sub required_modules_for {
      my($self, $dist) = @_;
  
      my $meta = $self->installed_meta($dist)
          or die "Couldn't find install metadata for $dist";
  
      my %excludes = (
          perl => 1,
          'ExtUtils::MakeMaker' => 1,
          'Module::Build' => 1,
      );
  
      grep !$excludes{$_},
          $meta->effective_prereqs->requirements_for('runtime', 'requires')->required_modules;
  }
  
  sub installed_meta {
      my($self, $dist) = @_;
  
      my @meta;
      my $finder = sub {
          if (m!\b$dist-.*[\\/]MYMETA.json!) {
              my $meta = CPAN::Meta->load_file($_);
              push @meta, $meta if $meta->name eq $dist;
          }
      };
  
      my @meta_dirs = grep -d, map "$_/.meta", @INC;
      File::Find::find({ wanted => $finder, no_chdir => 1 }, @meta_dirs)
          if @meta_dirs;
  
      # return the latest version
      @meta = sort { version->new($b->version) cmp version->new($a->version) } @meta;
  
      return $meta[0];
  }
  
  1;
CARTON_PACKER

$fatpacked{"Carton/Snapshot.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_SNAPSHOT';
  package Carton::Snapshot;
  use strict;
  use Config;
  use Carton::Dist;
  use Carton::Dist::Core;
  use Carton::Error;
  use Carton::Package;
  use Carton::Index;
  use Carton::Util;
  use Carton::Snapshot::Emitter;
  use Carton::Snapshot::Parser;
  use CPAN::Meta;
  use CPAN::Meta::Requirements;
  use File::Find ();
  use Try::Tiny;
  use Path::Tiny ();
  use Module::CoreList;
  
  use constant CARTON_SNAPSHOT_VERSION => '1.0';
  
  use subs 'path';
  use Class::Tiny {
      path => undef,
      version => sub { CARTON_SNAPSHOT_VERSION },
      loaded => undef,
      _distributions => sub { +[] },
  };
  
  sub BUILD {
      my $self = shift;
      $self->path( $self->{path} );
  }    
  
  sub path {
      my $self = shift;
      if (@_) {
          $self->{path} = Path::Tiny->new($_[0]);
      } else {
          $self->{path};
      }
  }
  
  sub load_if_exists {
      my $self = shift;
      $self->load if $self->path->is_file;
  }
  
  sub load {
      my $self = shift;
  
      return 1 if $self->loaded;
  
      if ($self->path->is_file) {
          my $parser = Carton::Snapshot::Parser->new;
          $parser->parse($self->path->slurp_utf8, $self);
          $self->loaded(1);
  
          return 1;
      } else {
          Carton::Error::SnapshotNotFound->throw(
              error => "Can't find cpanfile.snapshot: Run `carton install` to build the snapshot file.",
              path => $self->path,
          );
      }
  }
  
  sub save {
      my $self = shift;
      $self->path->spew_utf8( Carton::Snapshot::Emitter->new->emit($self) );
  }
  
  sub find {
      my($self, $module) = @_;
      (grep $_->provides_module($module), $self->distributions)[0];
  }
  
  sub find_or_core {
      my($self, $module) = @_;
      $self->find($module) || $self->find_in_core($module);
  }
  
  sub find_in_core {
      my($self, $module) = @_;
  
      if (exists $Module::CoreList::version{$]}{$module}) {
          my $version = $Module::CoreList::version{$]}{$module}; # maybe undef
          return Carton::Dist::Core->new(name => $module, module_version => $version);
      }
  
      return;
  }
  
  sub index {
      my $self = shift;
  
      my $index = Carton::Index->new;
      for my $package ($self->packages) {
          $index->add_package($package);
      }
  
      return $index;
  }
  
  sub distributions {
      @{$_[0]->_distributions};
  }
  
  sub add_distribution {
      my($self, $dist) = @_;
      push @{$self->_distributions}, $dist;
  }
  
  sub remove_distributions {
      my($self, $filter) = @_;
      my @dists = grep !$filter->($_), $self->distributions;
      $self->_distributions(\@dists);
  }
  
  sub packages {
      my $self = shift;
  
      my @packages;
      for my $dist ($self->distributions) {
          while (my($package, $provides) = each %{$dist->provides}) {
              # TODO what if duplicates?
              push @packages, Carton::Package->new($package, $provides->{version}, $dist->pathname);
          }
      }
  
      return @packages;
  }
  
  sub write_index {
      my($self, $file) = @_;
  
      open my $fh, ">", $file or die $!;
      $self->index->write($fh);
  }
  
  sub find_installs {
      my($self, $path, $reqs) = @_;
  
      my $libdir = "$path/lib/perl5/$Config{archname}/.meta";
      return {} unless -e $libdir;
  
      my @installs;
      my $wanted = sub {
          if ($_ eq 'install.json') {
              push @installs, [ $File::Find::name, "$File::Find::dir/MYMETA.json" ];
          }
      };
      File::Find::find($wanted, $libdir);
  
      my %installs;
  
      my $accepts = sub {
          my $module = shift;
  
          return 0 unless $reqs->accepts_module($module->{name}, $module->{provides}{$module->{name}}{version});
  
          if (my $exist = $installs{$module->{name}}) {
              my $old_ver = version::->new($exist->{provides}{$module->{name}}{version});
              my $new_ver = version::->new($module->{provides}{$module->{name}}{version});
              return $new_ver >= $old_ver;
          } else {
              return 1;
          }
      };
  
      for my $file (@installs) {
          my $module = Carton::Util::load_json($file->[0]);
          my $prereqs = -f $file->[1] ? CPAN::Meta->load_file($file->[1])->effective_prereqs : CPAN::Meta::Prereqs->new;
  
          my $reqs = CPAN::Meta::Requirements->new;
          $reqs->add_requirements($prereqs->requirements_for($_, 'requires'))
            for qw( configure build runtime );
  
          if ($accepts->($module)) {
              $installs{$module->{name}} = Carton::Dist->new(
                  name => $module->{dist},
                  pathname => $module->{pathname},
                  provides => $module->{provides},
                  version => $module->{version},
                  requirements => $reqs,
              );
          }
      }
  
      my @new_dists;
      for my $module (sort keys %installs) {
          push @new_dists, $installs{$module};
      }
  
      $self->_distributions(\@new_dists);
  }
  
  1;
CARTON_SNAPSHOT

$fatpacked{"Carton/Snapshot/Emitter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_SNAPSHOT_EMITTER';
  package Carton::Snapshot::Emitter;
  use Class::Tiny;
  use warnings NONFATAL => 'all';
  
  sub emit {
      my($self, $snapshot) = @_;
  
      my $data = '';
      $data .= "# carton snapshot format: version @{[$snapshot->version]}\n";
      $data .= "DISTRIBUTIONS\n";
  
      for my $dist (sort { $a->name cmp $b->name } $snapshot->distributions) {
          $data .= "  @{[$dist->name]}\n";
          $data .= "    pathname: @{[$dist->pathname]}\n";
  
          $data .= "    provides:\n";
          for my $package (sort keys %{$dist->provides}) {
              my $version = $dist->provides->{$package}{version};
              $version = 'undef' unless defined $version;
              $data .= "      $package $version\n";
          }
  
          $data .= "    requirements:\n";
          for my $module (sort $dist->required_modules) {
              $data .= "      $module @{[ $dist->requirements_for_module($module) || '0' ]}\n";
          }
      }
  
      $data;
  }
  
  1;
CARTON_SNAPSHOT_EMITTER

$fatpacked{"Carton/Snapshot/Parser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_SNAPSHOT_PARSER';
  package Carton::Snapshot::Parser;
  use Class::Tiny;
  use warnings NONFATAL => 'all';
  use Carton::Dist;
  use Carton::Error;
  
  my $machine = {
      init => [
          {
              re => qr/^\# carton snapshot format: version (1\.0)/,
              code => sub {
                  my($stash, $snapshot, $ver) = @_;
                  $snapshot->version($ver);
              },
              goto => 'section',
          },
          # TODO support pasing error and version mismatch etc.
      ],
      section => [
          {
              re => qr/^DISTRIBUTIONS$/,
              goto => 'dists',
          },
          {
              re => qr/^__EOF__$/,
              done => 1,
          },
      ],
      dists => [
          {
              re => qr/^  (\S+)$/,
              code => sub { $_[0]->{dist} = Carton::Dist->new(name => $1) },
              goto => 'distmeta',
          },
          {
              re => qr/^\S/,
              goto => 'section',
              redo => 1,
          },
      ],
      distmeta => [
          {
              re => qr/^    pathname: (.*)$/,
              code => sub { $_[0]->{dist}->pathname($1) },
          },
          {
              re => qr/^\s{4}provides:$/,
              code => sub { $_[0]->{property} = 'provides' },
              goto => 'properties',
          },
          {
              re => qr/^\s{4}requirements:$/,
              code => sub {
                  $_[0]->{property} = 'requirements';
              },
              goto => 'properties',
          },
          {
              re => qr/^\s{0,2}\S/,
              code => sub {
                  my($stash, $snapshot) = @_;
                  $snapshot->add_distribution($stash->{dist});
                  %$stash = (); # clear
              },
              goto => 'dists',
              redo => 1,
          },
      ],
      properties => [
          {
              re => qr/^\s{6}([0-9A-Za-z_:]+) ([v0-9\._,=\!<>\s]+|undef)/,
              code => sub {
                  my($stash, $snapshot, $module, $version) = @_;
                  if ($stash->{property} eq 'provides') {
                      $stash->{dist}->provides->{$module} = { version => $version };
                  } else {
                      $stash->{dist}->add_string_requirement($module, $version);
                  }
              },
          },
          {
              re => qr/^\s{0,4}\S/,
              goto => 'distmeta',
              redo => 1,
          },
      ],
  };
  
  sub parse {
      my($self, $data, $snapshot) = @_;
  
      my @lines = split /\r?\n/, $data;
  
      my $state = $machine->{init};
      my $stash = {};
  
      LINE:
      for my $line (@lines, '__EOF__') {
          last LINE unless @$state;
  
      STATE: {
              for my $trans (@{$state}) {
                  if (my @match = $line =~ $trans->{re}) {
                      if (my $code = $trans->{code}) {
                          $code->($stash, $snapshot, @match);
                      }
                      if (my $goto = $trans->{goto}) {
                          $state = $machine->{$goto};
                          if ($trans->{redo}) {
                              redo STATE;
                          } else {
                              next LINE;
                          }
                      }
  
                      last STATE;
                  }
              }
  
              Carton::Error::SnapshotParseError->throw(error => "Could not parse snapshot file: $line");
          }
      }
  }
  
  1;
CARTON_SNAPSHOT_PARSER

$fatpacked{"Carton/Tree.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_TREE';
  package Carton::Tree;
  use strict;
  use Carton::Dependency;
  
  use Class::Tiny qw( cpanfile snapshot );
  
  use constant STOP => -1;
  
  sub walk_down {
      my($self, $cb) = @_;
  
      my $dumper; $dumper = sub {
          my($dependency, $reqs, $level, $parent) = @_;
  
          my $ret = $cb->($dependency, $reqs, $level);
          return if $ret && $ret == STOP;
  
          local $parent->{$dependency->distname} = 1 if $dependency;
  
          for my $module (sort $reqs->required_modules) {
              my $dependency = $self->dependency_for($module, $reqs);
              if ($dependency->dist) {
                  next if $parent->{$dependency->distname};
                  $dumper->($dependency, $dependency->requirements, $level + 1, $parent);
              } else {
                  # no dist found in lock
              }
          }
      };
  
      $dumper->(undef, $self->cpanfile->requirements, 0, {});
      undef $dumper;
  }
  
  sub dependency_for {
      my($self, $module, $reqs) = @_;
  
      my $requirement = $reqs->requirements_for_module($module);
  
      my $dep = Carton::Dependency->new;
      $dep->module($module);
      $dep->requirement($requirement);
  
      if (my $dist = $self->snapshot->find_or_core($module)) {
          $dep->dist($dist);
      }
  
      return $dep;
  }
  
  sub merged_requirements {
      my $self = shift;
  
      my $merged_reqs = CPAN::Meta::Requirements->new;
  
      my %seen;
      $self->walk_down(sub {
          my($dependency, $reqs, $level) = @_;
          return Carton::Tree::STOP if $dependency && $seen{$dependency->distname}++;
          $merged_reqs->add_requirements($reqs);
      });
  
      $merged_reqs->clear_requirement('perl');
      $merged_reqs->finalize;
  
      $merged_reqs;
  }
  
  1;
CARTON_TREE

$fatpacked{"Carton/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_UTIL';
  package Carton::Util;
  use strict;
  use warnings;
  
  sub load_json {
      my $file = shift;
  
      open my $fh, "<", $file or die "$file: $!";
      from_json(join '', <$fh>);
  }
  
  sub dump_json {
      my($data, $file) = @_;
  
      open my $fh, ">", $file or die "$file: $!";
      binmode $fh;
      print $fh to_json($data);
  }
  
  sub from_json {
      require JSON::PP;
      JSON::PP->new->utf8->decode($_[0])
  }
  
  sub to_json {
      my($data) = @_;
      require JSON::PP;
      JSON::PP->new->utf8->pretty->canonical->encode($data);
  }
  
  1;
CARTON_UTIL

$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.008';
  
  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.008';
  
  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.008
  
  =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 are ignored.  Errors are caught and rethrown.
  
      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.
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =for stopwords Dagfinn Ilmari Mannsåker David Golden Gelu Lupas Karen Etheridge Matt S Trout 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 *
  
  Matt S Trout <mstrout@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{"ExtUtils/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CONFIG';
  package ExtUtils::Config;
  $ExtUtils::Config::VERSION = '0.010';
  use strict;
  use warnings;
  use Config;
  
  sub new {
  	my ($pack, $args) = @_;
  	return bless {
  		values => ($args ? { %$args } : {}),
  	}, $pack;
  }
  
  sub get {
  	my ($self, $key) = @_;
  	return exists $self->{values}{$key} ? $self->{values}{$key} : $Config{$key};
  }
  
  sub exists {
  	my ($self, $key) = @_;
  	return exists $self->{values}{$key} || exists $Config{$key};
  }
  
  sub values_set {
  	my $self = shift;
  	return { %{$self->{values}} };
  }
  
  sub all_config {
  	my $self = shift;
  	return { %Config, %{ $self->{values}} };
  }
  
  sub serialize {
  	my $self = shift;
  	require Data::Dumper;
  	return $self->{serialized} ||= Data::Dumper->new([ $self->{values} ])->Terse(1)->Sortkeys(1)->Dump;
  }
  
  sub but {
  	my ($self, $args) = @_;
  	my %new = %{ $self->{values} };
  	for my $key (keys %$args) {
  		if (defined $args->{$key}) {
  			$new{$key} = $args->{$key}
  		}
  		else {
  			delete $new{$key};
  		}
  	}
  	return bless { values => \%new }, ref $self;
  }
  
  1;
  
  # ABSTRACT: A wrapper for perl's configuration
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  ExtUtils::Config - A wrapper for perl's configuration
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
   my $config = ExtUtils::Config->new();
   $config->get('installsitelib');
  
  =head1 DESCRIPTION
  
  ExtUtils::Config is an abstraction around the %Config hash. By itself it is not a particularly interesting module by any measure, however it ties together a family of modern toolchain modules.
  
  =head1 METHODS
  
  =head2 new(\%config)
  
  Create a new ExtUtils::Config object. The values in C<\%config> are used to initialize the object.
  
  =head2 get($key)
  
  Get the value of C<$key>. If not overridden it will return the value in %Config.
  
  =head2 exists($key)
  
  Tests for the existence of $key.
  
  =head2 but(\%keys)
  
  This creates a new C<ExtUtils::Config> object based on the current one, but with the values in %keys replacing the current values. Any undefined value means it will be removed from the overriden set.
  
  =head2 values_set()
  
  Get a hashref of all overridden values.
  
  =head2 all_config()
  
  Get a hashref of the complete configuration, including overrides.
  
  =head2 serialize()
  
  This method serializes the object to some kind of string. This can be useful for various caching purposes.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Module::Build::Tiny>
  
  =item * L<ExtUtils::InstallPaths>
  
  =item * L<CPAN::Static::Install>
  
  =item * L<ExtUtils::HasCompiler>
  
  =item * L<ExtUtils::Builder>
  
  =item * L<CPAN::Requirements::Dynamic>
  
  =item * L<Devel::FindPerl>
  
  =back
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2006 by Ken Williams, 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
EXTUTILS_CONFIG

$fatpacked{"ExtUtils/Config/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CONFIG_MAKEMAKER';
  package ExtUtils::Config::MakeMaker;
  $ExtUtils::Config::MakeMaker::VERSION = '0.010';
  use strict;
  use warnings;
  
  use ExtUtils::MakeMaker::Config;
  
  sub new {
      my ($class, $maker) = @_;
      return bless { maker => $maker }, $class;
  }
  
  sub get {
      my ($self, $key) = @_;
      return exists $self->{maker}{uc $key} ? $self->{maker}{uc $key} : $Config{$key};
  }
  
  sub exists {
      my ($self, $key) = @_;
  	return exists $Config{$key};
  }
  
  sub all_config {
  	my $self = shift;
  	my %result;
  	for my $key (keys %Config) {
  		$result{$key} = $self->get($key);
  	}
  	return \%result;
  }
  
  sub values_set {
  	my $self = shift;
  	my %result;
  	for my $key (keys %Config) {
  		next if not exists $self->{maker}{uc $key};
  		next if $self->{maker}{uc $key} eq $Config{$key};
  		$result{$key} = $self->{maker}{uc $key};
  	}
  	return \%result;
  }
  
  sub serialize {
  	my $self = shift;
  	require Data::Dumper;
  	return $self->{serialized} ||= Data::Dumper->new($self->values_set)->Terse(1)->Sortkeys(1)->Dump;
  }
  
  sub materialize {
  	my $self = shift;
  	require ExtUtils::Config;
  	return ExtUtils::Config->new($self->values_set);
  }
  
  sub but {
  	my ($self, %args) = @_;
  	return $self->materialize->but(%args);
  }
  
  1;
  
  #ABSTRACT: A ExtUtils::Config compatible wrapper for ExtUtils::MakeMaker's configuration.
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  ExtUtils::Config::MakeMaker - A ExtUtils::Config compatible wrapper for ExtUtils::MakeMaker's configuration.
  
  =head1 VERSION
  
  version 0.010
  
  =head1 SYNOPSIS
  
   my $config = ExtUtils::Config::MakeMaker->new($makemaker);
  
  =head1 DESCRIPTION
  
  This object wraps L<ExtUtils::MakeMaker|ExtUtils::MakeMaker>'s idea of configuration in an L<ExtUtils::Config|ExtUtils::Config> compatible interface. That means that if you pass a configuration argument to or in Makefile.PL (e.g. C<OPTIMIZE=-O3>) it will show up in the config object (e.g. C<$config->get('optimize')>.
  
  =head1 METHODS
  
  =head2 new($makemaker)
  
  This creates a new C<ExtUtils::Config::MakeMaker> object from a MakeMaker object.
  
  =head2 get($key)
  
  Get the value of C<$key>. If not overridden it will return the value in %Config.
  
  =head2 exists($key)
  
  Tests for the existence of $key.
  
  =head2 values_set()
  
  Get a hashref of all overridden values.
  
  =head2 all_config()
  
  Get a hashref of the complete configuration, including overrides.
  
  =head2 serialize()
  
  This method serializes the object to some kind of string. This can be useful for various caching purposes.
  
  =head2 materialize()
  
  This turns this object into an actual C<ExtUtils::Config> object.
  
  =head2 but(%config)
  
  This returns a C<ExtUtils::Config> object based on the current one but with the given entries overriden. If any value is C<undef> it will revert to the official C<%Config> value instead.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2006 by Ken Williams, 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
EXTUTILS_CONFIG_MAKEMAKER

$fatpacked{"ExtUtils/Helpers.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS';
  package ExtUtils::Helpers;
  $ExtUtils::Helpers::VERSION = '0.028';
  use strict;
  use warnings FATAL => 'all';
  use Exporter 5.57 'import';
  
  use Config;
  use File::Basename qw/basename/;
  use File::Spec::Functions qw/splitpath canonpath abs2rel splitdir/;
  
  our @EXPORT_OK = qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
  
  BEGIN {
  	my %impl_for = ( MSWin32 => 'Windows', VMS => 'VMS');
  	my $package = 'ExtUtils::Helpers::' . ($impl_for{$^O} || 'Unix');
  	my $impl = $impl_for{$^O} || 'Unix';
  	require "ExtUtils/Helpers/$impl.pm";
  	"ExtUtils::Helpers::$impl"->import();
  }
  
  sub man1_pagename {
  	my ($filename, $ext) = @_;
  	$ext ||= $Config{man1ext};
  	return basename($filename).".$ext";
  }
  
  my %separator = (
  	MSWin32 => '.',
  	VMS => '__',
  	os2 => '.',
  	cygwin => '.',
  );
  my $separator = $separator{$^O} || '::';
  
  sub man3_pagename {
  	my ($filename, $base, $ext) = @_;
  	$base ||= 'lib';
  	$ext  ||= $Config{man3ext};
  	my ($vols, $dirs, $file) = splitpath(canonpath(abs2rel($filename, $base)));
  	$file = basename($file, qw/.pm .pod/);
  	my @dirs = grep { length } splitdir($dirs);
  	return join $separator, @dirs, "$file.$ext";
  }
  
  1;
  
  # ABSTRACT: Various portability utilities for module builders
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  ExtUtils::Helpers - Various portability utilities for module builders
  
  =head1 VERSION
  
  version 0.028
  
  =head1 SYNOPSIS
  
   use ExtUtils::Helpers qw/make_executable split_like_shell/;
  
   unshift @ARGV, split_like_shell($ENV{PROGRAM_OPTS});
   write_script_to('Build');
   make_executable('Build');
  
  =head1 DESCRIPTION
  
  This module provides various portable helper functions for module building modules.
  
  =head1 FUNCTIONS
  
  =head2 make_executable($filename)
  
  This makes a perl script executable.
  
  =head2 split_like_shell($string)
  
  This function splits a string the same way as the local platform does.
  
  =head2 detildefy($path)
  
  This function substitutes a tilde at the start of a path with the users homedir in an appropriate manner.
  
  =head2 man1_pagename($filename, $ext = $Config{man1ext})
  
  Returns the man page filename for a script.
  
  =head2 man3_pagename($filename, $basedir = 'lib', $ext = $Config{man3ext})
  
  Returns the man page filename for a Perl library.
  
  =head1 ACKNOWLEDGEMENTS
  
  Olivier Mengué and Christian Walde made C<make_executable> work on Windows.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2004 by Ken Williams, 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
EXTUTILS_HELPERS

$fatpacked{"ExtUtils/Helpers/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS_UNIX';
  package ExtUtils::Helpers::Unix;
  $ExtUtils::Helpers::Unix::VERSION = '0.028';
  use strict;
  use warnings FATAL => 'all';
  
  use Exporter 5.57 'import';
  our @EXPORT = qw/make_executable split_like_shell detildefy/;
  
  use Carp qw/croak/;
  use Config;
  use Text::ParseWords 3.24 qw/shellwords/;
  
  my $layer = $] >= 5.008001 ? ":raw" : "";
  
  sub make_executable {
  	my $filename = shift;
  	my $current_mode = (stat $filename)[2] + 0;
  	if (-T $filename) {
  		open my $fh, "<$layer", $filename;
  		my @lines = <$fh>;
  		if (@lines and $lines[0] =~ s{ \A \#! \s* (?:/\S+/)? perl \b (.*) \z }{$Config{startperl}$1}xms) {
  			open my $out, ">$layer", "$filename.new" or croak "Couldn't open $filename.new: $!";
  			print $out @lines;
  			close $out;
  			rename $filename, "$filename.bak" or croak "Couldn't rename $filename to $filename.bak";
  			rename "$filename.new", $filename or croak "Couldn't rename $filename.new to $filename";
  			unlink "$filename.bak";
  		}
  	}
  	chmod $current_mode | oct(111), $filename;
  	return;
  }
  
  sub split_like_shell {
  	my ($string) = @_;
  
  	return if not defined $string;
  	$string =~ s/^\s+|\s+$//g;
  	return if not length $string;
  
  	return shellwords($string);
  }
  
  sub detildefy {
  	my $value = shift;
  	# tilde with optional username
  	for ($value) {
  		s{ ^ ~ (?= /|$)}          [ $ENV{HOME} || (getpwuid $>)[7] ]ex or # tilde without user name
  		s{ ^ ~ ([^/]+) (?= /|$) } { (getpwnam $1)[7] || "~$1" }ex;        # tilde with user name
  	}
  	return $value;
  }
  
  1;
  
  # ABSTRACT: Unix specific helper bits
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  ExtUtils::Helpers::Unix - Unix specific helper bits
  
  =head1 VERSION
  
  version 0.028
  
  =for Pod::Coverage make_executable
  split_like_shell
  detildefy
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2004 by Ken Williams, 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
EXTUTILS_HELPERS_UNIX

$fatpacked{"ExtUtils/Helpers/VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS_VMS';
  package ExtUtils::Helpers::VMS;
  $ExtUtils::Helpers::VMS::VERSION = '0.028';
  use strict;
  use warnings FATAL => 'all';
  
  use Exporter 5.57 'import';
  our @EXPORT = qw/make_executable split_like_shell detildefy/;
  
  use ExtUtils::Helpers::Unix qw/split_like_shell/; # Probably very wrong, but whatever
  use File::Copy qw/copy/;
  
  sub make_executable {
  	my $filename = shift;
  	my $batchname = "$filename.com";
  	copy($filename, $batchname);
  	ExtUtils::Helpers::Unix::make_executable($batchname);
  	return;
  }
  
  sub detildefy {
  	my $arg = shift;
  
  	# Apparently double ~ are not translated.
  	return $arg if ($arg =~ /^~~/);
  
  	# Apparently ~ followed by whitespace are not translated.
  	return $arg if ($arg =~ /^~ /);
  
  	if ($arg =~ /^~/) {
  		my $spec = $arg;
  
  		# Remove the tilde
  		$spec =~ s/^~//;
  
  		# Remove any slash following the tilde if present.
  		$spec =~ s#^/##;
  
  		# break up the paths for the merge
  		my $home = VMS::Filespec::unixify($ENV{HOME});
  
  		# In the default VMS mode, the trailing slash is present.
  		# In Unix report mode it is not.  The parsing logic assumes that
  		# it is present.
  		$home .= '/' unless $home =~ m#/$#;
  
  		# Trivial case of just ~ by it self
  		if ($spec eq '') {
  			$home =~ s#/$##;
  			return $home;
  		}
  
  		my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
  		if ($hdir eq '') {
  			 # Someone has tampered with $ENV{HOME}
  			 # So hfile is probably the directory since this should be
  			 # a path.
  			 $hdir = $hfile;
  		}
  
  		my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
  
  		my @hdirs = File::Spec::Unix->splitdir($hdir);
  		my @dirs = File::Spec::Unix->splitdir($dir);
  
  		unless ($arg =~ m#^~/#) {
  			# There is a home directory after the tilde, but it will already
  			# be present in in @hdirs so we need to remove it by from @dirs.
  
  			shift @dirs;
  		}
  		my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
  
  		$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
  	}
  	return $arg;
  }
  
  # ABSTRACT: VMS specific helper bits
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  ExtUtils::Helpers::VMS - VMS specific helper bits
  
  =head1 VERSION
  
  version 0.028
  
  =for Pod::Coverage make_executable
  detildefy
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2004 by Ken Williams, 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
EXTUTILS_HELPERS_VMS

$fatpacked{"ExtUtils/Helpers/Windows.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS_WINDOWS';
  package ExtUtils::Helpers::Windows;
  $ExtUtils::Helpers::Windows::VERSION = '0.028';
  use strict;
  use warnings FATAL => 'all';
  
  use Exporter 5.57 'import';
  our @EXPORT = qw/make_executable split_like_shell detildefy/;
  
  use Config;
  use Carp qw/carp croak/;
  use ExtUtils::PL2Bat 'pl2bat';
  
  sub make_executable {
  	my $script = shift;
  	if (-T $script && $script !~ / \. (?:bat|cmd) $ /x) {
  		pl2bat(in => $script, update => 1);
  	}
  	return;
  }
  
  sub split_like_shell {
  	# 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 ($_) = @_;
  
  	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 =~ /\s/ && !$quote_mode ) {
  			push @argv, $arg if $arg;
  			$arg = '';
  			++$i while substr( $_, $i + 1, 1 ) =~ /\s/;
  		} else {
  			$arg .= $ch;
  		}
  
  		$i++;
  	}
  
  	push @argv, $arg if defined $arg && length $arg;
  	return @argv;
  }
  
  sub detildefy {
  	my $value = shift;
  	$value =~ s{ ^ ~ (?= [/\\] | $ ) }[$ENV{USERPROFILE}]x if $ENV{USERPROFILE};
  	return $value;
  }
  
  1;
  
  # ABSTRACT: Windows specific helper bits
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  ExtUtils::Helpers::Windows - Windows specific helper bits
  
  =head1 VERSION
  
  version 0.028
  
  =for Pod::Coverage make_executable
  split_like_shell
  detildefy
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2004 by Ken Williams, 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
EXTUTILS_HELPERS_WINDOWS

$fatpacked{"ExtUtils/InstallPaths.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALLPATHS';
  package ExtUtils::InstallPaths;
  $ExtUtils::InstallPaths::VERSION = '0.014';
  use 5.008;
  use strict;
  use warnings;
  
  use File::Spec ();
  use Carp ();
  use ExtUtils::Config 0.009;
  
  my %complex_accessors = map { $_ => 1 } qw/prefix_relpaths install_sets/;
  my %hash_accessors = map { $_ => 1 } qw/install_path install_base_relpaths original_prefix /;
  
  my %defaults = (
  	installdirs     => 'site',
  	install_base    => undef,
  	prefix          => undef,
  	verbose         => 0,
  	create_packlist => 1,
  	dist_name       => undef,
  	module_name     => undef,
  	destdir         => undef,
  	install_path    => sub { {} },
  	install_sets    => \&_default_install_sets,
  	original_prefix => \&_default_original_prefix,
  	install_base_relpaths => \&_default_base_relpaths,
  	prefix_relpaths => \&_default_prefix_relpaths,
  );
  
  sub _merge_shallow {
  	my ($name, $filter) = @_;
  	return sub {
  		my ($override, $config) = @_;
  		my $defaults = $defaults{$name}->($config);
  		$filter->($_) for grep $filter, values %$override;
  		return { %$defaults, %$override };
  	}
  }
  
  sub _merge_deep {
  	my ($name, $filter) = @_;
  	return sub {
  		my ($override, $config) = @_;
  		my $defaults = $defaults{$name}->($config);
  		my $pair_for = sub {
  			my $key = shift;
  			my %override = %{ $override->{$key} || {} };
  			$filter && $filter->($_) for values %override;
  			return $key => { %{ $defaults->{$key} }, %override };
  		};
  		return { map { $pair_for->($_) } keys %$defaults };
  	}
  }
  
  my %allowed_installdir = map { $_ => 1 } qw/core site vendor/;
  my $must_be_relative = sub { Carp::croak('Value must be a relative path') if File::Spec->file_name_is_absolute($_[0]) };
  my %deep_filter = map { $_ => $must_be_relative } qw/install_base_relpaths prefix_relpaths/;
  my %filter = (
  	installdirs => sub {
  		my $value = shift;
  		$value = 'core', Carp::carp('Perhaps you meant installdirs to be "core" rather than "perl"?') if $value eq 'perl';
  		Carp::croak('installdirs must be one of "core", "site", or "vendor"') if not $allowed_installdir{$value};
  		return $value;
  	},
  	(map { $_ => _merge_shallow($_, $deep_filter{$_}) } qw/original_prefix install_base_relpaths/),
  	(map { $_ => _merge_deep($_, $deep_filter{$_}) } qw/install_sets prefix_relpaths/),
  );
  
  sub new {
  	my ($class, %args) = @_;
  	my $config = $args{config} || ExtUtils::Config->new;
  	if ($config->get('installsitescript') eq '') {
  		$config = $config->but({ installsitescript => $config->get('installsitebin') });
  	}
  	my %self = (
  		config => $config,
  		map { $_ => exists $args{$_} ? $filter{$_} ? $filter{$_}->($args{$_}, $config) : $args{$_} : ref $defaults{$_} ? $defaults{$_}->($config) : $defaults{$_} } keys %defaults,
  	);
  	$self{module_name} ||= do { my $module_name = $self{dist_name}; $module_name =~ s/-/::/g; $module_name } if defined $self{dist_name};
  	return bless \%self, $class;
  }
  
  for my $attribute (keys %defaults) {
  	no strict qw/refs/;
  	*{$attribute} = $hash_accessors{$attribute} ? 
  	sub {
  		my ($self, $key) = @_;
  		Carp::confess("$attribute needs key") if not defined $key;
  		return $self->{$attribute}{$key};
  	} :
  	$complex_accessors{$attribute} ?
  	sub {
  		my ($self, $installdirs, $key) = @_;
  		Carp::confess("$attribute needs installdir") if not defined $installdirs;
  		Carp::confess("$attribute needs key") if not defined $key;
  		return $self->{$attribute}{$installdirs}{$key};
  	} :
  	sub {
  		my $self = shift;
  		return $self->{$attribute};
  	};
  }
  
  my @install_sets_keys = qw/lib arch bin script bindoc libdoc binhtml libhtml/;
  my @install_sets_tail = qw/bin script man1dir man3dir html1dir html3dir/;
  my %install_sets_values = (
  	core   => [ qw/privlib archlib/, @install_sets_tail ],
  	site   => [ map { "site$_" } qw/lib arch/, @install_sets_tail ],
  	vendor => [ map { "vendor$_" } qw/lib arch/, @install_sets_tail ],
  );
  
  sub _default_install_sets {
  	my $c = shift;
  
  	my %ret;
  	for my $installdir (qw/core site vendor/) {
  		@{$ret{$installdir}}{@install_sets_keys} = map { $c->get("install$_") } @{ $install_sets_values{$installdir} };
  	}
  	return \%ret;
  }
  
  sub _default_base_relpaths {
  	my $config = shift;
  	return {
  		lib     => ['lib', 'perl5'],
  		arch    => ['lib', 'perl5', $config->get('archname')],
  		bin     => ['bin'],
  		script  => ['bin'],
  		bindoc  => ['man', 'man1'],
  		libdoc  => ['man', 'man3'],
  		binhtml => ['html'],
  		libhtml => ['html'],
  	};
  }
  
  my %common_prefix_relpaths = (
  	bin        => ['bin'],
  	script     => ['bin'],
  	bindoc     => ['man', 'man1'],
  	libdoc     => ['man', 'man3'],
  	binhtml    => ['html'],
  	libhtml    => ['html'],
  );
  
  sub _default_prefix_relpaths {
  	my $c = shift;
  
  	my @libstyle = $c->get('installstyle') ?  File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
  	my $arch     = $c->get('archname');
  	my $version  = $c->get('version');
  
  	return {
  		core => {
  			lib        => [@libstyle],
  			arch       => [@libstyle, $version, $arch],
  			%common_prefix_relpaths,
  		},
  		vendor => {
  			lib        => [@libstyle],
  			arch       => [@libstyle, $version, $arch],
  			%common_prefix_relpaths,
  		},
  		site => {
  			lib        => [@libstyle, 'site_perl'],
  			arch       => [@libstyle, 'site_perl', $version, $arch],
  			%common_prefix_relpaths,
  		},
  	};
  }
  
  sub _default_original_prefix {
  	my $c = shift;
  
  	my %ret = (
  		core   => $c->get('installprefixexp'),
  		site   => $c->get('siteprefixexp'),
  		vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
  	);
  
  	return \%ret;
  }
  
  sub _log_verbose {
  	my $self = shift;
  	print @_ if $self->verbose;
  	return;
  }
  
  # Given a file type, will return true if the file type would normally
  # be installed when neither install-base nor prefix has been set.
  # I.e. it will be true only if the path is set from Config.pm or
  # set explicitly by the user via install-path.
  sub is_default_installable {
  	my $self = shift;
  	my $type = shift;
  	my $installable = $self->install_destination($type) && ( $self->install_path($type) || $self->install_sets($self->installdirs, $type));
  	return $installable ? 1 : 0;
  }
  
  sub _prefixify_default {
  	my $self = shift;
  	my $type = shift;
  	my $rprefix = shift;
  
  	my $default = $self->prefix_relpaths($self->installdirs, $type);
  	if( !$default ) {
  		$self->_log_verbose("    no default install location for type '$type', using prefix '$rprefix'.\n");
  		return $rprefix;
  	} else {
  		return File::Spec->catdir(@{$default});
  	}
  }
  
  # Translated from ExtUtils::MM_Unix::prefixify()
  sub _prefixify_novms {
  	my($self, $path, $sprefix, $type) = @_;
  
  	my $rprefix = $self->prefix;
  	$rprefix .= '/' if $sprefix =~ m{/$};
  
  	$self->_log_verbose("  prefixify $path from $sprefix to $rprefix\n") if defined $path && length $path;
  
  	if (not defined $path or length $path == 0 ) {
  		$self->_log_verbose("  no path to prefixify, falling back to default.\n");
  		return $self->_prefixify_default( $type, $rprefix );
  	} elsif( !File::Spec->file_name_is_absolute($path) ) {
  		$self->_log_verbose("    path is relative, not prefixifying.\n");
  	} elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) {
  		$self->_log_verbose("    cannot prefixify, falling back to default.\n");
  		return $self->_prefixify_default( $type, $rprefix );
  	}
  
  	$self->_log_verbose("    now $path in $rprefix\n");
  
  	return $path;
  }
  
  sub _catprefix_vms {
  	my ($self, $rprefix, $default) = @_;
  
  	my ($rvol, $rdirs) = File::Spec->splitpath($rprefix);
  	if ($rvol) {
  		return File::Spec->catpath($rvol, File::Spec->catdir($rdirs, $default), '');
  	}
  	else {
  		return File::Spec->catdir($rdirs, $default);
  	}
  }
  sub _prefixify_vms {
  	my($self, $path, $sprefix, $type) = @_;
  	my $rprefix = $self->prefix;
  
  	return '' unless defined $path;
  
  	$self->_log_verbose("  prefixify $path from $sprefix to $rprefix\n");
  
  	require VMS::Filespec;
  	# Translate $(PERLPREFIX) to a real path.
  	$rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
  	$sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
  
  	$self->_log_verbose("  rprefix translated to $rprefix\n  sprefix translated to $sprefix\n");
  
  	if (length($path) == 0 ) {
  		$self->_log_verbose("  no path to prefixify.\n")
  	}
  	elsif (!File::Spec->file_name_is_absolute($path)) {
  		$self->_log_verbose("	path is relative, not prefixifying.\n");
  	}
  	elsif ($sprefix eq $rprefix) {
  		$self->_log_verbose("  no new prefix.\n");
  	}
  	else {
  		my ($path_vol, $path_dirs) = File::Spec->splitpath( $path );
  		my $vms_prefix = $self->config->get('vms_prefix');
  		if ($path_vol eq $vms_prefix.':') {
  			$self->_log_verbose("  $vms_prefix: seen\n");
  
  			$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
  			$path = $self->_catprefix_vms($rprefix, $path_dirs);
  		}
  		else {
  			$self->_log_verbose("	cannot prefixify.\n");
  			return File::Spec->catdir($self->prefix_relpaths($self->installdirs, $type));
  		}
  	}
  
  	$self->_log_verbose("	now $path\n");
  
  	return $path;
  }
  
  BEGIN { *_prefixify = $^O eq 'VMS' ? \&_prefixify_vms : \&_prefixify_novms }
  
  # Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
  sub prefix_relative {
  	my ($self, $installdirs, $type) = @_;
  
  	my $relpath = $self->install_sets($installdirs, $type);
  
  	return $self->_prefixify($relpath, $self->original_prefix($installdirs), $type);
  }
  
  sub install_destination {
  	my ($self, $type) = @_;
  
  	return $self->install_path($type) if $self->install_path($type);
  
  	if ( $self->install_base ) {
  		my $relpath = $self->install_base_relpaths($type);
  		return $relpath ? File::Spec->catdir($self->install_base, @{$relpath}) : undef;
  	}
  
  	if ( $self->prefix ) {
  		my $relpath = $self->prefix_relative($self->installdirs, $type);
  		return $relpath ? File::Spec->catdir($self->prefix, $relpath) : undef;
  	}
  	return $self->install_sets($self->installdirs, $type);
  }
  
  sub install_types {
  	my $self = shift;
  
  	my %types = ( %{ $self->{install_path} }, 
  		  $self->install_base ?  %{ $self->{install_base_relpaths} }
  		: $self->prefix ? %{ $self->{prefix_relpaths}{ $self->installdirs } }
  		: %{ $self->{install_sets}{ $self->installdirs } });
  
  	return sort keys %types;
  }
  
  sub install_map {
  	my ($self, $dirs) = @_;
  
  	my %localdir_for;
  	if ($dirs && %$dirs) {
  		%localdir_for = %$dirs;
  	}
  	else {
  		foreach my $type ($self->install_types) {
  			$localdir_for{$type} = File::Spec->catdir('blib', $type);
  		}
  	}
  
  	my (%map, @skipping);
  	foreach my $type (keys %localdir_for) {
  		next if not $self->is_default_installable($type);
  		if (my $dest = $self->install_destination($type)) {
  			$map{$localdir_for{$type}} = $dest;
  		} else {
  			push @skipping, $type;
  		}
  	}
  
  	warn "WARNING: Can't figure out install path for types: @skipping\nFiles will not be installed.\n" if @skipping;
  
  	# Write the packlist into the same place as ExtUtils::MakeMaker.
  	if ($self->create_packlist and my $module_name = $self->module_name) {
  		my $archdir = $self->install_destination('arch');
  		my @ext = split /::/, $module_name;
  		$map{write} = File::Spec->catfile($archdir, 'auto', @ext, '.packlist');
  	}
  
  	# Handle destdir
  	if (length(my $destdir = $self->destdir || '')) {
  		foreach (keys %map) {
  			# Need to remove volume from $map{$_} using splitpath, or else
  			# we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
  			# VMS will always have the file separate than the path.
  			my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 0 );
  
  			# catdir needs a list of directories, or it will create something
  			# crazy like volume:[Foo.Bar.volume.Baz.Quux]
  			my @dirs = File::Spec->splitdir($path);
  
  			# First merge the directories
  			$path = File::Spec->catdir($destdir, @dirs);
  
  			# Then put the file back on if there is one.
  			if ($file ne '') {
  			    $map{$_} = File::Spec->catfile($path, $file)
  			} else {
  			    $map{$_} = $path;
  			}
  		}
  	}
  
  	$map{read} = '';  # To keep ExtUtils::Install quiet
  
  	return \%map;
  }
  
  1;
  
  # ABSTRACT: Build.PL install path logic made easy
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  ExtUtils::InstallPaths - Build.PL install path logic made easy
  
  =head1 VERSION
  
  version 0.014
  
  =head1 SYNOPSIS
  
   use ExtUtils::InstallPaths;
   use ExtUtils::Install 'install';
   GetOptions(\my %opt, 'install_base=s', 'install_path=s%', 'installdirs=s', 'destdir=s', 'prefix=s', 'uninst:1', 'verbose:1');
   my $paths = ExtUtils::InstallPaths->new(%opt, dist_name => $dist_name);
   install($paths->install_map, $opt{verbose}, 0, $opt{uninst});
  
  =head1 DESCRIPTION
  
  This module tries to make install path resolution as easy as possible.
  
  When you want to install a module, it needs to figure out where to install things. The nutshell version of how this works is that default installation locations are determined from L<ExtUtils::Config>, and they may be individually overridden by using the C<install_path> attribute. An C<install_base> attribute lets you specify an alternative installation root like F</home/foo> and C<prefix> does something similar in a rather different (and more complicated) way. C<destdir> lets you specify a temporary installation directory like F</tmp/install> in case you want to create bundled-up installable packages.
  
  The following types are supported by default.
  
  =over 4
  
  =item * lib
  
  Usually pure-Perl module files ending in F<.pm> or F<.pod>.
  
  =item * arch
  
  "Architecture-dependent" module files, usually produced by compiling XS, L<Inline>, or similar code.
  
  =item * script
  
  Programs written in pure Perl.  In order to improve reuse, you may want to make these as small as possible - put the code into modules whenever possible.
  
  =item * bin
  
  "Architecture-dependent" executable programs, i.e. compiled C code or something.  Pretty rare to see this in a perl distribution, but it happens.
  
  =item * bindoc
  
  Documentation for the stuff in C<script> and C<bin>.  Usually generated from the POD in those files.  Under Unix, these are manual pages belonging to the 'man1' category. Unless explicitly set, this is only available on platforms supporting manpages.
  
  =item * libdoc
  
  Documentation for the stuff in C<lib> and C<arch>.  This is usually generated from the POD in F<.pm> and F<.pod> files.  Under Unix, these are manual pages belonging to the 'man3' category. Unless explicitly set, this is only available on platforms supporting manpages.
  
  =item * binhtml
  
  This is the same as C<bindoc> above, but applies to HTML documents. Unless explicitly set, this is only available when perl was configured to do so.
  
  =item * libhtml
  
  This is the same as C<libdoc> above, but applies to HTML documents. Unless explicitly set, this is only available when perl was configured to do so.
  
  =back
  
  =head1 ATTRIBUTES
  
  =head2 installdirs
  
  The default destinations for these installable things come from entries in your system's configuration. You can select from three different sets of default locations by setting the C<installdirs> parameter as follows:
  
                            'installdirs' set to:
                     core          site                vendor
  
                uses the following defaults from ExtUtils::Config:
  
    lib     => installprivlib  installsitelib      installvendorlib
    arch    => installarchlib  installsitearch     installvendorarch
    script  => installscript   installsitescript   installvendorscript
    bin     => installbin      installsitebin      installvendorbin
    bindoc  => installman1dir  installsiteman1dir  installvendorman1dir
    libdoc  => installman3dir  installsiteman3dir  installvendorman3dir
    binhtml => installhtml1dir installsitehtml1dir installvendorhtml1dir [*]
    libhtml => installhtml3dir installsitehtml3dir installvendorhtml3dir [*]
  
    * Under some OS (eg. MSWin32) the destination for HTML documents is determined by the C<Config.pm> entry C<installhtmldir>.
  
  The default value of C<installdirs> is "site".
  
  =head2 install_base
  
  You can also set the whole bunch of installation paths by supplying the C<install_base> parameter to point to a directory on your system.  For instance, if you set C<install_base> to "/home/ken" on a Linux system, you'll install as follows:
  
    lib     => /home/ken/lib/perl5
    arch    => /home/ken/lib/perl5/i386-linux
    script  => /home/ken/bin
    bin     => /home/ken/bin
    bindoc  => /home/ken/man/man1
    libdoc  => /home/ken/man/man3
    binhtml => /home/ken/html
    libhtml => /home/ken/html
  
  =head2 prefix
  
  This sets a prefix, identical to ExtUtils::MakeMaker's PREFIX option. This does something similar to C<install_base> in a much more complicated way.
  
  =head2 config()
  
  The L<ExtUtils::Config|ExtUtils::Config> object used for this object.
  
  =head2 verbose
  
  The verbosity of ExtUtils::InstallPaths. It defaults to 0
  
  =head2 create_packlist
  
  Together with C<module_name> this controls whether a packlist will be added; it defaults to 1.
  
  =head2 dist_name
  
  The name of the current module.
  
  =head2 module_name
  
  The name of the main module of the package. This is required for packlist creation, but in the future it may be replaced by dist_name. It defaults to C<dist_name =~ s/-/::/gr> if dist_name is set.
  
  =head2 destdir
  
  If you want to install everything into a temporary directory first (for instance, if you want to create a directory tree that a package manager like C<rpm> or C<dpkg> could create a package from), you can use the C<destdir> parameter. E.g. Setting C<destdir> to C<"/tmp/foo"> will effectively install to "/tmp/foo/$sitelib", "/tmp/foo/$sitearch", and the like, except that it will use C<File::Spec> to make the pathnames work correctly on whatever platform you're installing on.
  
  =head1 METHODS
  
  =head2 new
  
  Create a new ExtUtils::InstallPaths object. B<All attributes are valid arguments> to the constructor, as well as this:
  
  =over 4
  
  =item * install_path
  
  This must be a hashref with the type as keys and the destination as values.
  
  =item * install_base_relpaths
  
  This must be a hashref with types as keys and a path relative to the install_base as value.
  
  =item * prefix_relpaths
  
  This must be a hashref any of these three keys: core, vendor, site. Each of the values mush be a hashref with types as keys and a path relative to the prefix as value. You probably want to make these three hashrefs identical.
  
  =item * original_prefix
  
  This must be a hashref with the legal installdirs values as keys and the prefix directories as values.
  
  =item * install_sets
  
  This mush be a hashref with the legal installdirs are keys, and the values being hashrefs with types as keys and locations as values.
  
  =back
  
  =head2 install_map()
  
  Return a map suitable for use with L<ExtUtils::Install>. B<In most cases, this is the only method you'll need>.
  
  =head2 install_destination($type)
  
  Returns the destination of a certain type.
  
  =head2 install_types()
  
  Return a list of all supported install types in the current configuration.
  
  =head2 is_default_installable($type)
  
  Given a file type, will return true if the file type would normally be installed when neither install-base nor prefix has been set.  I.e. it will be true only if the path is set from the configuration object or set explicitly by the user via install_path.
  
  =head2 install_path($type)
  
  Gets the install path for a certain type.
  
  =head2 install_sets($installdirs, $type)
  
  Get the path for a certain C<$type> with a certain C<$installdirs>.
  
  =head2 install_base_relpaths($type, $relpath)
  
  Get the relative paths for use with install_base for a certain type.
  
  =head2 prefix_relative($installdirs, $type)
  
  Gets the path of a certain C<$type> and C<$installdirs> relative to the prefix.
  
  =head2 prefix_relpaths($install_dirs, $type)
  
  Get the default relative path to use in case the config install paths cannot be prefixified. You do not want to use this to get any relative path, but may require it to set it for custom types.
  
  =head2 original_prefix($installdirs)
  
  Get the original prefix for a certain type of $installdirs.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Build.PL spec|http://github.com/dagolden/cpan-api-buildpl/blob/master/lib/CPAN/API/BuildPL.pm>
  
  =back
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Ken Williams <kwilliams@cpan.org>
  
  =item *
  
  Leon Timmermans <leont@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Ken Williams, 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
EXTUTILS_INSTALLPATHS

$fatpacked{"File/Which.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_WHICH';
  package File::Which;
  
  use strict;
  use warnings;
  use base qw( Exporter );
  use File::Spec ();
  
  # ABSTRACT: Perl implementation of the which utility as an API
  our $VERSION = '1.27'; # VERSION
  
  
  our @EXPORT    = 'which';
  our @EXPORT_OK = 'where';
  
  use constant IS_VMS => ($^O eq 'VMS');
  use constant IS_MAC => ($^O eq 'MacOS');
  use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
  use constant IS_DOS => IS_WIN();
  use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys');
  
  our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC;
  
  # 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_WIN ) {
    # 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;  ## no critic (Freenode::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  ## no critic (ValuesAndExpressions::ProhibitMixedBooleanOperators)
            if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec;
  
    my @path;
    if($^O eq 'MSWin32') {
      # File::Spec (at least recent versions)
      # add the implicit . for you on MSWin32,
      # but we may or may not want to include
      # that.
      @path = split /;/, $ENV{PATH};
      s/"//g for @path;
      @path = grep length, @path;
    } else {
      @path = File::Spec->path;
    }
    if ( $IMPLICIT_CURRENT_DIR ) {
      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  ## no critic (ValuesAndExpressions::ProhibitMixedBooleanOperators)
            ||
            (
              ( IS_WIN or IS_CYG )
              and
              grep {   ## no critic (BuiltinFunctions::ProhibitBooleanGrep)
                $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.27
  
  =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 ME, 98, 95, 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.  Similar to the C<where> csh
  built-in command or C<which -a> command for platforms that support the
  C<-a> option. Will return an array containing all the path names
  matching C<$short_exe_name>.
  
  =head1 GLOBALS
  
  =head2 $IMPLICIT_CURRENT_DIR
  
  True if the current directory is included in the search implicitly on
  whatever platform you are using.  Normally the default is reasonable,
  but on Windows the current directory is included implicitly for older
  shells like C<cmd.exe> and C<command.com>, but not for newer shells
  like PowerShell.  If you overrule this default, you should ALWAYS
  localize the variable to the tightest scope possible, since setting
  this variable from a module can affect other modules.  Thus on Windows
  you can get the correct result if the user is running either C<cmd.exe>
  or PowerShell on Windows you can do this:
  
   use File::Which qw( which );
   use Shell::Guess;
   
   my $path = do {
     my $is_power = Shell::Guess->running_shell->is_power;
     local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power;
     which 'foo';
   };
  
  For a variety of reasons it is difficult to accurately compute the
  shell that a user is using, but L<Shell::Guess> makes a reasonable
  effort.
  
  =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/uperl/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>
  
  Requires Perl 5.8.3.  Included as part of the Perl core as of 5.9.5.
  
  This module provides (among other things) a C<can_run> function, which is
  similar to C<which>.  It is a much heavier module since it does a lot more,
  and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>.  This combination
  may be overkill for applications which do not need L<IPC::Cmd>'s complicated
  interface for running programs, or do not need the memory overhead required
  for installing Perl modules.
  
  At least some older versions will find executables in the current directory,
  even if the current directory is not in the search path (which is the default
  on modern Unix).
  
  C<can_run> converts directory path name to the 8.3 version on Windows using
  C<Win32::GetShortPathName> in some cases.  This is frequently useful for tools
  that just need to run something using C<system> in scalar mode, but may be
  inconvenient for tools like L<App::pwhich> where user readability is a premium.
  Relying on C<Win32::GetShortPathName> to produce filenames without spaces
  is problematic, as 8.3 filenames can be turned off with tweaks to the
  registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>).
  
  =item L<Devel::CheckBin>
  
  Requires Perl 5.8.1.
  
  This module purports to "check that a command is available", but does not
  provide any documentation on how you might use it.
  
  This module also relies on L<ExtUtils::MakeMaker> so has the same overhead
  burdens as L<IPC::Cmd>.
  
  =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.016';
  
  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;
      $dir->{_owner} = $$;
      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->{_owner} == $$
          && !$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.016
  
  =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é Shoichi Kaji
  
  =over 4
  
  =item *
  
  Diab Jerius <djerius@cfa.harvard.edu>
  
  =item *
  
  Graham Ollis <plicease@cpan.org>
  
  =item *
  
  Olivier Mengué <dolmen@cpan.org>
  
  =item *
  
  Shoichi Kaji <skaji@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2018 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/Tinyish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH';
  package HTTP::Tinyish;
  use strict;
  use warnings;
  use Carp ();
  
  our $VERSION = '0.19';
  
  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 patch/) {
      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: L<LWP>, L<HTTP::Tiny>, C<curl>
  and C<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>, C<patch> 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 patch/ ) {
      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,
          {
              binmode_stdout => ":raw",
              binmode_stderr => ":raw",
          };
      };
  
      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,
          {
              binmode_stdout => ":raw",
              binmode_stderr => ":raw",
          };
      };
  
      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 = (
          '--silent',
          '--show-error',
          '--max-time', ($self->{timeout} || 60),
          '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
      );
      if (my $max_redirect = exists $self->{max_redirect} ? $self->{max_redirect} : 5) {
          push @options, '--location', '--max-redirs', $max_redirect;
      }
  
      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; require Mozilla::CA; 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(exists $attr{max_redirect} ? $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,
          {
              binmode_stdout => ":raw",
              binmode_stderr => ":raw",
          };
      };
  
      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', (exists $self->{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{"Menlo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO';
  package Menlo;
  our $VERSION = "1.9019";
  
  1;
  
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  Menlo - A CPAN client
  
  =head1 DESCRIPTION
  
  Menlo is a backend for I<cpanm 2.0>, developed with the goal to
  replace L<cpanm> internals with a set of modules that are more
  flexible, extensible and easier to use.
  
  =head1 COMPATIBILITY
  
  Menlo is developed within L<cpanminus> git repository at C<Menlo>
  subdirectory at L<https://github.com/miyagawa/cpanminus>
  
  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.
  
  =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 if you
  want to write a tool that works with cpanm, you basically 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.
  
  Menlo is a set of libraries and uses non-core CPAN modules as its
  dependencies. App-cpanminus distribution embeds Menlo and all of its
  runtime dependencies into a fatpacked binary, so that you can install
  App-cpanminus or Menlo without having any CPAN client to begin with.
  
  =item Is Menlo a new name for cpanm?
  
  Right now it's just a library 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';
  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/dirname/;
  use File::Find ();
  use File::Path qw/mkpath/;
  use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/;
  use Getopt::Long 2.36 qw/GetOptionsFromArray/;
  
  sub new {
      my($class, %args) = @_;
      bless {
          meta => $args{meta},
      }, $class;
  }
  
  sub meta {
      my $self = shift;
      $self->{meta};
  }
  
  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;
  	},
  );
  
  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}), $self->meta);
  	$actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name));
  }
  
  sub configure {
  	my $self = shift;   
  	$self->{env} = defined $ENV{PERL_MB_OPT} ? [split_like_shell($ENV{PERL_MB_OPT})] : [];
          $self->{configure_args} = [@_];
  	$self->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 = '1.9022';
  
  if ($INC{"App/FatPacker/Trace.pm"}) {
  # version:vpp is not in core Perl 5.40:    require version::vpp;
  }
  
  sub qs($) {
      Menlo::Util::shell_quote($_[0]);
  }
  
  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 {
          name => "Menlo",
          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,
          static_install => 1,
          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},
          'static-install!' => \$self->{static_install},
          '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 ($self->{name}) $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 =~ /(?:<|!=|==)/;
  }
  
  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 ($self->{name}) 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 _use_unsafe_inc {
      my($self, $dist) = @_;
  
      # if it's set in the env (i.e. user's shell), just use that
      if (exists $ENV{PERL_USE_UNSAFE_INC}) {
          return $ENV{PERL_USE_UNSAFE_INC};
      }
  
      # it's set in CPAN Meta, prefer what the author says
      if (exists $dist->{meta}{x_use_unsafe_inc}) {
          $self->chat("Distribution opts in x_use_unsafe_inc: $dist->{meta}{x_use_unsafe_inc}\n");
          return $dist->{meta}{x_use_unsafe_inc};
      }
  
      # otherwise set to 1 as a default to allow for old modules
      return 1;
  }
  
  sub configure {
      my($self, $cmd, $dist, $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} = $self->_use_unsafe_inc($dist);
  
      $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, $dist, $depth) = @_;
  
      local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
  
      local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
  
      $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, $dist, $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, $dist, $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} = $self->_use_unsafe_inc($dist);
  
      $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, $dist, $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, $dist, $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} = $self->_use_unsafe_inc($dist);
  
      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) {
          if (WIN32) {
              system "@{[ qs $pager ]} < @{[ qs $self->{log}]}";
          } else {
              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 = `@{[ qs $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 : {};
  
      if ($self->opts_in_static_install($dist->{cpanmeta})) {
          $dist->{static_install} = 1;
      }
  
      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, $dist, $depth) &&
          $self->test(sub { $configure_state->{static_install}->build("test") }, $distname, $dist, $depth) &&
          $self->install(sub { $configure_state->{static_install}->build("install") }, [], $dist, $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, $dist, $depth) &&
          $self->test([ $self->{perl}, "./Build", "test" ], $distname, $dist, $depth) &&
          $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $dist, $depth) &&
          $installed++;
      } elsif ($self->{make} && -e 'Makefile') {
          $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
          $self->build([ $self->{make} ], $distname, $dist, $depth) &&
          $self->test([ $self->{make}, "test" ], $distname, $dist, $depth) &&
          $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $dist, $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->is_downgrade($version, $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 is_downgrade {
      my($self, $va, $vb) = @_;
      eval { version::->new($va) < $vb };
  }
  
  sub opts_in_static_install {
      my($self, $meta) = @_;
  
      return if !$self->{static_install};
  
      # --sudo requires running a separate shell to prevent persistent configuration
      # uninstall-shadows (default on < 5.12) is not supported in BuildPL spec, yet.
      return if $self->{sudo} or $self->{uninstall_shadows};
  
      return $meta->{x_static_install} && $meta->{x_static_install} == 1;
  }
  
  sub skip_configure {
      my($self, $dist, $depth) = @_;
  
      return 1 if $self->{skip_configure};
      return 1 if $dist->{static_install};
      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 ($dist->{static_install}) {
              $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" ], $dist, $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" ], $dist, $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(meta => $dist->{cpanmeta});
      $self->configure(sub { $builder->configure($args || []) }, $dist, $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 = $meta->effective_prereqs(\@features)->clone;
      $self->adjust_prereqs($dist, $prereqs);
  
      return Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
  }
  
  sub adjust_prereqs {
      my($self, $dist, $prereqs) = @_;
  
      # 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
      if (-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);
              }
          }
      }
  
      # Static installation is optional and we're adding runtime dependencies
      if ($dist->{static_install}) {
          my $reqs = $prereqs->requirements_for('test' => 'requires');
          $reqs->add_minimum('TAP::Harness::Env' => 0);
      }
  }
  
  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 = `@{[ qs $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) = `@{[ qs $tar ]} ${ar}tf @{[ qs $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;
                  }
              }
  
              $self->run_command([ $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) = `@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $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 "@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $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) = `@{[ qs $unzip ]} -t @{[ qs $zipfile ]}`
                  or return undef;
              FILE: {
                  chomp $root;
                  if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
                      $root = shift(@others);
                      redo FILE if $root;
                  }
              }
  
              $self->run_command([ $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;
  
  __END__
  
  =encoding utf-8
  
  =head1 NAME
  
  Menlo::CLI::Compat - cpanm compatible CPAN installer
  
  =head1 SYNOPSIS
  
    use Menlo::CLI::Compat;
  
    my $app = Menlo::CLI::Compat->new;
    $app->parse_options(@ARGV);
    $app->run;
  
  =head1 DESCRIPTION
  
  Menlo::CLI::Compat is a port of App::cpanminus to Menlo, and provides
  a compatibility layer for users and clients to depend on the specific
  cpanm behaviors.
  
  =head1 SEE ALSO
  
  L<Menlo>, L<Menlo::Legacy>
  
  =cut
  
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 = "1.9019";
  
  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} ? () :

                     # Hotpatch by the OTOBO Team 2026-02-12.
                     # Download via HTTP does not work, HTTPS is preferred anyways
                     #(download_uri => "http://backpan.perl.org/authors/id/$match->{distfile}")),
                     (download_uri => "https://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/Legacy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_LEGACY';
  package Menlo::Legacy;
  
  use strict;
  our $VERSION = '1.9022';
  
  1;
  __END__
  
  =encoding utf-8
  
  =head1 NAME
  
  Menlo::Legacy - Legacy internal and client support for Menlo
  
  =head1 DESCRIPTION
  
  Menlo::Legacy is a package to install L<Menlo::CLI::Compat> which is a
  compatibility library that implements the classic version of cpanminus
  internals and behavios. This is so that existing users of cpanm and
  API clients such as L<Carton>, L<Carmel> and L<App::cpm>) can rely on
  the stable features and specific behaviors of cpanm.
  
  This way Menlo can evolve and be refactored without the fear of
  breaking any downstream clients, including C<cpanm> itself.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2018- Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<Menlo::CLI::Compat>
  
  =cut
MENLO_LEGACY

$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.1004';
  
  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 @others = map { $self->feature($_)->prereqs } @feature_identifiers;
      $self->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 _d($) {
      require Data::Dumper;
      chomp(my $value = Data::Dumper->new([$_[0]])->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 .= "feature @{[ _d $feature->{identifier} ]}, @{[ _d $feature->{description} ]} => sub {\n";
          $code .= $self->_dump_prereqs($feature->{prereqs}->as_string_hash, $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 @{[ _d $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));
  
          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 @{[ _d $mod ]}"
                               : "${indent}$type @{[ _d $mod ]}, @{[ _d $ver ]}";
  
                  my $options = $self->options_for_module($mod) || {};
                  if (%$options) {
                      my @opts;
                      for my $key (keys %$options) {
                          my $k = $key =~ /^[a-zA-Z0-9_]+$/ ? $key : _d $key;
                          push @opts, "$k => @{[ _d $options->{$k} ]}";
                      }
  
                      $phase_code .= ",\n" . join(",\n", map "  $indent$_", @opts);
                  }
  
                  $phase_code .= ";\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.
  
  =item options_for_module
  
    my $options = $file->options_for_module($module);
  
  Returns the extra options specified for a given module as a hash
  reference. Returns C<undef> when the given module is not specified in
  the C<cpanfile>.
  
  For example,
  
    # cpanfile
    requires 'Plack', '1.000',
      dist => "MIYAGAWA/Plack-1.000.tar.gz";
  
    # ...
    my $file = Module::CPANfile->load;
    my $options = $file->options_for_module('Plack');
    # => { dist => "MIYAGAWA/Plack-1.000.tar.gz" }
  
  =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(
          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} }
  
  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(
                      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 {
      my($self, %args) = @_;
  
      my $feature = $args{feature} || '';
      push @{$self->{prereqs}{$feature}},
        Module::CPANfile::Prereq->new(%args);
  }
  
  sub as_cpan_meta {
      my $self = shift;
      $self->{cpanmeta} ||= $self->build_cpan_meta;
  }
  
  sub build_cpan_meta {
      my($self, $feature) = @_;
      CPAN::Meta::Prereqs->new($self->specs($feature));
  }
  
  sub specs {
      my($self, $feature) = @_;
  
      $feature = ''
        unless defined $feature;
  
      my $prereqs = $self->{prereqs}{$feature} || [];
      my $specs = {};
  
      for my $prereq (@$prereqs) {
           $specs->{$prereq->phase}{$prereq->type}{$prereq->module} =
             $prereq->requirement->version;
      }
  
      return $specs;
  }
  
  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 $feature ('', keys %{$self->{features}}) {
          for my $prereq (@{$self->{prereqs}{$feature}}) {
              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{"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.47';
  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;
              my $eval = qq{
                  local(\$^W) = 0;
                  Parse::PMFile::_parse_version_safely("$pmcp");
              };
              unless ($self->{UNSAFE} || $UNSAFE) {
                  $comp = Safe->new;
                  $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 = $comp ? $comp->reval($eval) : eval $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 = $comp ? $comp->reval($vstr) : eval $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 if ($comp);
                  $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;
  
      my $package_or_class = 'package';
      my $checked_bom;
    PLINE: while (<$fh>) {
          chomp;
          my($pline) = $_;
          $pline =~ s/\A(?:\x00\x00\xfe\xff|\xff\xfe\x00\x00|\xfe\xff|\xff\xfe|\xef\xbb\xbf)// unless $checked_bom;
          $checked_bom = 1;
          $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;
          }
  
  =pod
          # hide in the pod block until 'class' is added to a version bundle
          if ($pline =~ /^[\s\{;]*use\s(+v?5\.[0-9]+)/) {
              my $version = $1;
              my $version_bundle_for_class = version->parse("v5.xx.xx");
              if (eval { version->parse($version) >= $version_bundle_for_class) {
                  $package_or_class = 'package|class|role';
              }
              next PLINE;
          }
  =cut
  
          # use feature 'class'; enabels class (and role, though not implemented yet)
          if ($pline =~ /^[\s\{;]*use\s+(?:feature|experimental)\s+[^;]+\b(?:class|all)[^;]*;/) {
              $package_or_class = 'package|class';
          }
  
          # some modules also enables class and role
          # XXX: what to do with MooseX::Declare and a few minor experiments)
          if ($pline =~ /^[\s\{;]*use\s+(?:Feature::Compat::Class)[^;]*;/) {
              $package_or_class = 'package|class';
          }
          if ($pline =~ /^[\s\{;]*use\s+(?:Object::Pad)[^;]*;/) {
              $package_or_class = 'package|class|role';
          }
  
          my $pkg;
          my $strict_version;
  
          if (
              $pline =~ m{
                        # (.*) # takes too much time if $pline is long
                        #(?<![*\$\\@%&]) # no sigils
                        ^[\s\{;]*
                        \b(?:$package_or_class)\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;
              $ppp->{$pkg}{version} .= "";    # make sure to stringify version
          } 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{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_TINY';
  use 5.008001;
  use strict;
  use warnings;
  
  package Path::Tiny;
  # ABSTRACT: File path utility
  
  our $VERSION = '0.148';
  
  # Dependencies
  use Config;
  use Exporter 5.57   (qw/import/);
  use File::Spec 0.86 ();          # shipped with 5.8.1
  use Carp ();
  
  our @EXPORT    = qw/path/;
  our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
  
  use constant {
      PATH     => 0,
      CANON    => 1,
      VOL      => 2,
      DIR      => 3,
      FILE     => 4,
      TEMP     => 5,
      IS_WIN32 => ( $^O eq 'MSWin32' ),
  };
  
  use overload (
      q{""}    => 'stringify',
      bool     => sub () { 1 },
      fallback => 1,
  );
  
  # FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
  sub THAW   { return path( $_[2] ) }
  { no warnings 'once'; *TO_JSON = *FREEZE = \&stringify };
  
  my $HAS_UU; # has Unicode::UTF8; lazily populated
  
  sub _check_UU {
      local $SIG{__DIE__}; # prevent outer handler from being called
      !!eval {
          require Unicode::UTF8;
          Unicode::UTF8->VERSION(0.58);
          1;
      };
  }
  
  my $HAS_PU;              # has PerlIO::utf8_strict; lazily populated
  
  sub _check_PU {
      local $SIG{__DIE__}; # prevent outer handler from being called
      !!eval {
          # MUST preload Encode or $SIG{__DIE__} localization fails
          # on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2.
          require Encode;
          require PerlIO::utf8_strict;
          PerlIO::utf8_strict->VERSION(0.003);
          1;
      };
  }
  
  my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
  
  # notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
  my $SLASH      = qr{[\\/]};
  my $NOTSLASH   = qr{[^\\/]};
  my $DRV_VOL    = qr{[a-z]:}i;
  my $UNC_VOL    = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x;
  my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x;
  
  sub _win32_vol {
      my ( $path, $drv ) = @_;
      require Cwd;
      my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd
      # getdcwd on non-existent drive returns empty string
      # so just use the original drive Z: -> Z:
      $dcwd = "$drv" unless defined $dcwd && length $dcwd;
      # normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z:
      $dcwd =~ s{$SLASH?\z}{/};
      # make the path absolute with dcwd
      $path =~ s{^$DRV_VOL}{$dcwd};
      return $path;
  }
  
  # This is a string test for before we have the object; see is_rootdir for well-formed
  # object test
  sub _is_root {
      return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
  }
  
  BEGIN {
      *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
  }
  
  # mode bits encoded for chmod in symbolic mode
  my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic
  { my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ };
  
  sub _symbolic_chmod {
      my ( $mode, $symbolic ) = @_;
      for my $clause ( split /,\s*/, $symbolic ) {
          if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
              my ( $who, $action, $perms ) = ( $1, $2, $3 );
              $who =~ s/a/ugo/g;
              for my $w ( split //, $who ) {
                  my $p = 0;
                  $p |= $MODEBITS{"$w$_"} for split //, $perms;
                  if ( $action eq '=' ) {
                      $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p;
                  }
                  else {
                      $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p );
                  }
              }
          }
          else {
              Carp::croak("Invalid mode clause '$clause' for chmod()");
          }
      }
      return $mode;
  }
  
  # flock doesn't work on NFS on BSD or on some filesystems like lustre.
  # Since program authors often can't control or detect that, we warn once
  # instead of being fatal if we can detect it and people who need it strict
  # can fatalize the 'flock' category
  
  #<<< No perltidy
  { package flock; use warnings::register }
  #>>>
  
  my $WARNED_NO_FLOCK = 0;
  
  sub _throw {
      my ( $self, $function, $file, $msg ) = @_;
      if (   $function =~ /^flock/
          && $! =~ /operation not supported|function not implemented/i
          && !warnings::fatal_enabled('flock') )
      {
          if ( !$WARNED_NO_FLOCK ) {
              warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
              $WARNED_NO_FLOCK++;
          }
      }
      else {
          $msg = $! unless defined $msg;
          Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
              $msg );
      }
      return;
  }
  
  # cheapo option validation
  sub _get_args {
      my ( $raw, @valid ) = @_;
      if ( defined($raw) && ref($raw) ne 'HASH' ) {
          my ( undef, undef, undef, $called_as ) = caller(1);
          $called_as =~ s{^.*::}{};
          Carp::croak("Options for $called_as must be a hash reference");
      }
      my $cooked = {};
      for my $k (@valid) {
          $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
      }
      if ( keys %$raw ) {
          my ( undef, undef, undef, $called_as ) = caller(1);
          $called_as =~ s{^.*::}{};
          Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
      }
      return $cooked;
  }
  
  #--------------------------------------------------------------------------#
  # Constructors
  #--------------------------------------------------------------------------#
  
  #pod =construct path
  #pod
  #pod     $path = path("foo/bar");
  #pod     $path = path("/tmp", "file.txt"); # list
  #pod     $path = path(".");                # cwd
  #pod
  #pod Constructs a C<Path::Tiny> object.  It doesn't matter if you give a file or
  #pod directory path.  It's still up to you to call directory-like methods only on
  #pod directories and file-like methods only on files.  This function is exported
  #pod automatically by default.
  #pod
  #pod The first argument must be defined and have non-zero length or an exception
  #pod will be thrown.  This prevents subtle, dangerous errors with code like
  #pod C<< path( maybe_undef() )->remove_tree >>.
  #pod
  #pod B<DEPRECATED>: If and only if the B<first> character of the B<first> argument
  #pod to C<path> is a tilde ('~'), then tilde replacement will be applied to the
  #pod first path segment. A single tilde will be replaced with C<glob('~')> and a
  #pod tilde followed by a username will be replaced with output of
  #pod C<glob('~username')>. B<No other method does tilde expansion on its arguments>.
  #pod See L</Tilde expansion (deprecated)> for more.
  #pod
  #pod On Windows, if the path consists of a drive identifier without a path component
  #pod (C<C:> or C<D:>), it will be expanded to the absolute path of the current
  #pod directory on that volume using C<Cwd::getdcwd()>.
  #pod
  #pod If called with a single C<Path::Tiny> argument, the original is returned unless
  #pod the original is holding a temporary file or directory reference in which case a
  #pod stringified copy is made.
  #pod
  #pod     $path = path("foo/bar");
  #pod     $temp = Path::Tiny->tempfile;
  #pod
  #pod     $p2 = path($path); # like $p2 = $path
  #pod     $t2 = path($temp); # like $t2 = path( "$temp" )
  #pod
  #pod This optimizes copies without proliferating references unexpectedly if a copy is
  #pod made by code outside your control.
  #pod
  #pod Current API available since 0.017.
  #pod
  #pod =cut
  
  sub path {
      my $path = shift;
      Carp::croak("Path::Tiny paths require defined, positive-length parts")
        unless 1 + @_ == grep { defined && length } $path, @_;
  
      # non-temp Path::Tiny objects are effectively immutable and can be reused
      if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
          return $path;
      }
  
      # stringify objects
      $path = "$path";
  
      # do any tilde expansions
      my ($tilde) = $path =~ m{^(~[^/]*)};
      if ( defined $tilde ) {
          # Escape File::Glob metacharacters
          (my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g;
          require File::Glob;
          my ($homedir) = File::Glob::bsd_glob($escaped);
          if (defined $homedir && ! $File::Glob::ERROR) {
              $homedir =~ tr[\\][/] if IS_WIN32();
              $path =~ s{^\Q$tilde\E}{$homedir};
          }
      }
  
      unshift @_, $path;
      goto &_pathify;
  }
  
  # _path is like path but without tilde expansion
  sub _path {
      my $path = shift;
      Carp::croak("Path::Tiny paths require defined, positive-length parts")
        unless 1 + @_ == grep { defined && length } $path, @_;
  
      # non-temp Path::Tiny objects are effectively immutable and can be reused
      if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
          return $path;
      }
  
      # stringify objects
      $path = "$path";
  
      unshift @_, $path;
      goto &_pathify;
  }
  
  # _pathify expects one or more string arguments, then joins and canonicalizes
  # them into an object.
  sub _pathify {
      my $path = shift;
  
      # expand relative volume paths on windows; put trailing slash on UNC root
      if ( IS_WIN32() ) {
          $path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH|\z)};
          $path .= "/" if $path =~ m{^$UNC_VOL\z};
      }
  
      # concatenations stringifies objects, too
      if (@_) {
          $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
      }
  
  
      # canonicalize, but with unix slashes and put back trailing volume slash
      my $cpath = $path = File::Spec->canonpath($path);
      $path =~ tr[\\][/] if IS_WIN32();
      $path = "/" if $path eq '/..'; # for old File::Spec
      $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z};
  
      # root paths must always have a trailing slash, but other paths must not
      if ( _is_root($path) ) {
          $path =~ s{/?\z}{/};
      }
      else {
          $path =~ s{/\z}{};
      }
  
      bless [ $path, $cpath ], __PACKAGE__;
  }
  
  #pod =construct new
  #pod
  #pod     $path = Path::Tiny->new("foo/bar");
  #pod
  #pod This is just like C<path>, but with method call overhead.  (Why would you
  #pod do that?)
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  sub new { shift; path(@_) }
  
  #pod =construct cwd
  #pod
  #pod     $path = Path::Tiny->cwd; # path( Cwd::getcwd )
  #pod     $path = cwd; # optional export
  #pod
  #pod Gives you the absolute path to the current directory as a C<Path::Tiny> object.
  #pod This is slightly faster than C<< path(".")->absolute >>.
  #pod
  #pod C<cwd> may be exported on request and used as a function instead of as a
  #pod method.
  #pod
  #pod Current API available since 0.018.
  #pod
  #pod =cut
  
  sub cwd {
      require Cwd;
      return _path( Cwd::getcwd() );
  }
  
  #pod =construct rootdir
  #pod
  #pod     $path = Path::Tiny->rootdir; # /
  #pod     $path = rootdir;             # optional export 
  #pod
  #pod Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too
  #pod picky for C<path("/")>.
  #pod
  #pod C<rootdir> may be exported on request and used as a function instead of as a
  #pod method.
  #pod
  #pod Current API available since 0.018.
  #pod
  #pod =cut
  
  sub rootdir { _path( File::Spec->rootdir ) }
  
  #pod =construct tempfile, tempdir
  #pod
  #pod     $temp = Path::Tiny->tempfile( @options );
  #pod     $temp = Path::Tiny->tempdir( @options );
  #pod     $temp = $dirpath->tempfile( @options );
  #pod     $temp = $dirpath->tempdir( @options );
  #pod     $temp = tempfile( @options ); # optional export
  #pod     $temp = tempdir( @options );  # optional export
  #pod
  #pod C<tempfile> passes the options to C<< File::Temp->new >> and returns a
  #pod C<Path::Tiny> object with the file name.  The C<TMPDIR> option will be enabled
  #pod by default, but you can override that by passing C<< TMPDIR => 0 >> along with
  #pod the options.  (If you use an absolute C<TEMPLATE> option, you will want to
  #pod disable C<TMPDIR>.)
  #pod
  #pod The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
  #pod destroyed, the C<File::Temp> object will be as well.
  #pod
  #pod C<File::Temp> annoyingly requires you to specify a custom template in slightly
  #pod different ways depending on which function or method you call, but
  #pod C<Path::Tiny> lets you ignore that and can take either a leading template or a
  #pod C<TEMPLATE> option and does the right thing.
  #pod
  #pod     $temp = Path::Tiny->tempfile( "customXXXXXXXX" );             # ok
  #pod     $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
  #pod
  #pod The tempfile path object will be normalized to have an absolute path, even if
  #pod created in a relative directory using C<DIR>.  If you want it to have
  #pod the C<realpath> instead, pass a leading options hash like this:
  #pod
  #pod     $real_temp = tempfile({realpath => 1}, @options);
  #pod
  #pod C<tempdir> is just like C<tempfile>, except it calls
  #pod C<< File::Temp->newdir >> instead.
  #pod
  #pod Both C<tempfile> and C<tempdir> may be exported on request and used as
  #pod functions instead of as methods.
  #pod
  #pod The methods can be called on an instances representing a
  #pod directory. In this case, the directory is used as the base to create the
  #pod temporary file/directory, setting the C<DIR> option in File::Temp.
  #pod
  #pod     my $target_dir = path('/to/destination');
  #pod     my $tempfile = $target_dir->tempfile('foobarXXXXXX');
  #pod     $tempfile->spew('A lot of data...');  # not atomic
  #pod     $tempfile->move($target_dir->child('foobar')); # hopefully atomic
  #pod
  #pod In this case, any value set for option C<DIR> is ignored.
  #pod
  #pod B<Note>: for tempfiles, the filehandles from File::Temp are closed and not
  #pod reused.  This is not as secure as using File::Temp handles directly, but is
  #pod less prone to deadlocks or access problems on some platforms.  Think of what
  #pod C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
  #pod up.
  #pod
  #pod B<Note 2>: if you don't want these cleaned up automatically when the object
  #pod is destroyed, File::Temp requires different options for directories and
  #pod files.  Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
  #pod files.
  #pod
  #pod B<Note 3>: Don't lose the temporary object by chaining a method call instead
  #pod of storing it:
  #pod
  #pod     my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
  #pod
  #pod B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
  #pod Keeping a reference to, or modifying the cached object may break the
  #pod behavior documented above and is not supported.  Use at your own risk.
  #pod
  #pod Current API available since 0.119.
  #pod
  #pod =cut
  
  sub tempfile {
      my ( $opts, $maybe_template, $args )
          = _parse_file_temp_args(tempfile => @_);
  
      # File::Temp->new demands TEMPLATE
      $args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
  
      require File::Temp;
      my $temp = File::Temp->new( TMPDIR => 1, %$args );
      close $temp;
      my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
      $self->[TEMP] = $temp;                # keep object alive while we are
      return $self;
  }
  
  sub tempdir {
      my ( $opts, $maybe_template, $args )
          = _parse_file_temp_args(tempdir => @_);
  
      require File::Temp;
      my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
      my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
      $self->[TEMP] = $temp;                # keep object alive while we are
      # Some ActiveState Perls for Windows break Cwd in ways that lead
      # File::Temp to get confused about what path to remove; this
      # monkey-patches the object with our own view of the absolute path
      $temp->{REALNAME} = $self->[CANON] if IS_WIN32;
      return $self;
  }
  
  # normalize the various ways File::Temp does templates
  sub _parse_file_temp_args {
      my $called_as = shift;
      if ( @_ && $_[0] eq 'Path::Tiny' ) { shift } # class method
      elsif ( @_ && eval{$_[0]->isa('Path::Tiny')} ) {
          my $dir = shift;
          if (! $dir->is_dir) {
              $dir->_throw( $called_as, $dir, "is not a directory object" );
          }
          push @_, DIR => $dir->stringify; # no overriding
      }
      my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
      $opts = _get_args( $opts, qw/realpath/ );
  
      my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
      my %args = @_;
      %args = map { uc($_), $args{$_} } keys %args;
      my @template = (
            exists $args{TEMPLATE} ? delete $args{TEMPLATE}
          : $leading_template      ? $leading_template
          :                          ()
      );
  
      return ( $opts, \@template, \%args );
  }
  
  #--------------------------------------------------------------------------#
  # Private methods
  #--------------------------------------------------------------------------#
  
  sub _splitpath {
      my ($self) = @_;
      @{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
  }
  
  sub _resolve_symlinks {
      my ($self) = @_;
      my $new = $self;
      my ( $count, %seen ) = 0;
      while ( -l $new->[PATH] ) {
          if ( $seen{ $new->[PATH] }++ ) {
              $self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
          }
          if ( ++$count > 100 ) {
              $self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
          }
          my $resolved = readlink $new->[PATH];
          $new->_throw( 'readlink', $new->[PATH] ) unless defined $resolved;
          $resolved = _path($resolved);
          $new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
      }
      return $new;
  }
  
  sub _replacement_path {
      my ($self) = @_;
  
      my $unique_suffix = $$ . int( rand( 2**31 ) );
      my $temp          = _path( $self . $unique_suffix );
  
      # If filename with process+random suffix is too long, use a shorter
      # version that doesn't preserve the basename.
      if ( length $temp->basename > 255 ) {
          $temp = $self->sibling( "temp" . $unique_suffix );
      }
  
      return $temp;
  }
  
  #--------------------------------------------------------------------------#
  # Public methods
  #--------------------------------------------------------------------------#
  
  #pod =method absolute
  #pod
  #pod     $abs = path("foo/bar")->absolute;
  #pod     $abs = path("foo/bar")->absolute("/tmp");
  #pod
  #pod Returns a new C<Path::Tiny> object with an absolute path (or itself if already
  #pod absolute).  If no argument is given, the current directory is used as the
  #pod absolute base path.  If an argument is given, it will be converted to an
  #pod absolute path (if it is not already) and used as the absolute base path.
  #pod
  #pod This will not resolve upward directories ("foo/../bar") unless C<canonpath>
  #pod in L<File::Spec> would normally do so on your platform.  If you need them
  #pod resolved, you must call the more expensive C<realpath> method instead.
  #pod
  #pod On Windows, an absolute path without a volume component will have it added
  #pod based on the current drive.
  #pod
  #pod Current API available since 0.101.
  #pod
  #pod =cut
  
  sub absolute {
      my ( $self, $base ) = @_;
  
      # absolute paths handled differently by OS
      if (IS_WIN32) {
          return $self if length $self->volume;
          # add missing volume
          if ( $self->is_absolute ) {
              require Cwd;
              # use Win32::GetCwd not Cwd::getdcwd because we're sure
              # to have the former but not necessarily the latter
              my ($drv) = Win32::GetCwd() =~ /^($DRV_VOL | $UNC_VOL)/x;
              return _path( $drv . $self->[PATH] );
          }
      }
      else {
          return $self if $self->is_absolute;
      }
  
      # no base means use current directory as base
      require Cwd;
      return _path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base;
  
      # relative base should be made absolute; we check is_absolute rather
      # than unconditionally make base absolute so that "/foo" doesn't become
      # "C:/foo" on Windows.
      $base = _path($base);
      return _path( ( $base->is_absolute ? $base : $base->absolute ), $_[0]->[PATH] );
  }
  
  #pod =method append, append_raw, append_utf8
  #pod
  #pod     path("foo.txt")->append(@data);
  #pod     path("foo.txt")->append(\@data);
  #pod     path("foo.txt")->append({binmode => ":raw"}, @data);
  #pod     path("foo.txt")->append_raw(@data);
  #pod     path("foo.txt")->append_utf8(@data);
  #pod
  #pod Appends data to a file.  The file is locked with C<flock> prior to writing
  #pod and closed afterwards.  An optional hash reference may be used to pass
  #pod options.  Valid options are:
  #pod
  #pod =for :list
  #pod * C<binmode>: passed to C<binmode()> on the handle used for writing.
  #pod * C<truncate>: truncates the file after locking and before appending
  #pod
  #pod The C<truncate> option is a way to replace the contents of a file
  #pod B<in place>, unlike L</spew> which writes to a temporary file and then
  #pod replaces the original (if it exists).
  #pod
  #pod C<append_raw> is like C<append> with a C<binmode> of C<:unix> for a fast,
  #pod unbuffered, raw write.
  #pod
  #pod C<append_utf8> is like C<append> with an unbuffered C<binmode>
  #pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
  #pod L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, an
  #pod unbuffered, raw append will be done instead on the data encoded with
  #pod C<Unicode::UTF8>.
  #pod
  #pod Current API available since 0.060.
  #pod
  #pod =cut
  
  sub append {
      my ( $self, @data ) = @_;
      my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
      $args = _get_args( $args, qw/binmode truncate/ );
      my $binmode = $args->{binmode};
      $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
      my $mode = $args->{truncate} ? ">" : ">>";
      my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
      print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data ) or $self->_throw('print');
      close $fh or $self->_throw('close');
  }
  
  sub append_raw {
      my ( $self, @data ) = @_;
      my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
      $args = _get_args( $args, qw/binmode truncate/ );
      $args->{binmode} = ':unix';
      append( $self, $args, @data );
  }
  
  sub append_utf8 {
      my ( $self, @data ) = @_;
      my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
      $args = _get_args( $args, qw/binmode truncate/ );
      if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
          $args->{binmode} = ":unix";
          append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
      }
      elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
          $args->{binmode} = ":unix:utf8_strict";
          append( $self, $args, @data );
      }
      else {
          $args->{binmode} = ":unix:encoding(UTF-8)";
          append( $self, $args, @data );
      }
  }
  
  #pod =method assert
  #pod
  #pod     $path = path("foo.txt")->assert( sub { $_->exists } );
  #pod
  #pod Returns the invocant after asserting that a code reference argument returns
  #pod true.  When the assertion code reference runs, it will have the invocant
  #pod object in the C<$_> variable.  If it returns false, an exception will be
  #pod thrown.  The assertion code reference may also throw its own exception.
  #pod
  #pod If no assertion is provided, the invocant is returned without error.
  #pod
  #pod Current API available since 0.062.
  #pod
  #pod =cut
  
  sub assert {
      my ( $self, $assertion ) = @_;
      return $self unless $assertion;
      if ( ref $assertion eq 'CODE' ) {
          local $_ = $self;
          $assertion->()
            or Path::Tiny::Error->throw( "assert", $self->[PATH], "failed assertion" );
      }
      else {
          Carp::croak("argument to assert must be a code reference argument");
      }
      return $self;
  }
  
  #pod =method basename
  #pod
  #pod     $name = path("foo/bar.txt")->basename;        # bar.txt
  #pod     $name = path("foo.txt")->basename('.txt');    # foo
  #pod     $name = path("foo.txt")->basename(qr/.txt/);  # foo
  #pod     $name = path("foo.txt")->basename(@suffixes);
  #pod
  #pod Returns the file portion or last directory portion of a path.
  #pod
  #pod Given a list of suffixes as strings or regular expressions, any that match at
  #pod the end of the file portion or last directory portion will be removed before
  #pod the result is returned.
  #pod
  #pod Current API available since 0.054.
  #pod
  #pod =cut
  
  sub basename {
      my ( $self, @suffixes ) = @_;
      $self->_splitpath unless defined $self->[FILE];
      my $file = $self->[FILE];
      for my $s (@suffixes) {
          my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
          last if $file =~ s/$re//;
      }
      return $file;
  }
  
  #pod =method canonpath
  #pod
  #pod     $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
  #pod
  #pod Returns a string with the canonical format of the path name for
  #pod the platform.  In particular, this means directory separators
  #pod will be C<\> on Windows.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  sub canonpath { $_[0]->[CANON] }
  
  #pod =method cached_temp
  #pod
  #pod Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
  #pod C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
  #pod If there is no such object, this method throws.
  #pod
  #pod B<WARNING>: Keeping a reference to, or modifying the cached object may
  #pod break the behavior documented for temporary files and directories created
  #pod with C<Path::Tiny> and is not supported.  Use at your own risk.
  #pod
  #pod Current API available since 0.101.
  #pod
  #pod =cut
  
  sub cached_temp {
      my $self = shift;
      $self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
        unless defined $self->[TEMP];
      return $self->[TEMP];
  }
  
  #pod =method child
  #pod
  #pod     $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
  #pod     $file = path("/tmp")->child(@parts);
  #pod
  #pod Returns a new C<Path::Tiny> object relative to the original.  Works
  #pod like C<catfile> or C<catdir> from File::Spec, but without caring about
  #pod file or directories.
  #pod
  #pod B<WARNING>: because the argument could contain C<..> or refer to symlinks,
  #pod there is no guarantee that the new path refers to an actual descendent of
  #pod the original.  If this is important to you, transform parent and child with
  #pod L</realpath> and check them with L</subsumes>.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  sub child {
      my ( $self, @parts ) = @_;
      return _path( $self->[PATH], @parts );
  }
  
  #pod =method children
  #pod
  #pod     @paths = path("/tmp")->children;
  #pod     @paths = path("/tmp")->children( qr/\.txt\z/ );
  #pod
  #pod Returns a list of C<Path::Tiny> objects for all files and directories
  #pod within a directory.  Excludes "." and ".." automatically.
  #pod
  #pod If an optional C<qr//> argument is provided, it only returns objects for child
  #pod names that match the given regular expression.  Only the base name is used
  #pod for matching:
  #pod
  #pod     @paths = path("/tmp")->children( qr/^foo/ );
  #pod     # matches children like the glob foo*
  #pod
  #pod Current API available since 0.028.
  #pod
  #pod =cut
  
  sub children {
      my ( $self, $filter ) = @_;
      my $dh;
      opendir $dh, $self->[PATH] or $self->_throw('opendir');
      my @children = readdir $dh;
      closedir $dh or $self->_throw('closedir');
  
      if ( not defined $filter ) {
          @children = grep { $_ ne '.' && $_ ne '..' } @children;
      }
      elsif ( $filter && ref($filter) eq 'Regexp' ) {
          @children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
      }
      else {
          Carp::croak("Invalid argument '$filter' for children()");
      }
  
      return map { _path( $self->[PATH], $_ ) } @children;
  }
  
  #pod =method chmod
  #pod
  #pod     path("foo.txt")->chmod(0777);
  #pod     path("foo.txt")->chmod("0755");
  #pod     path("foo.txt")->chmod("go-w");
  #pod     path("foo.txt")->chmod("a=r,u+wx");
  #pod
  #pod Sets file or directory permissions.  The argument can be a numeric mode, a
  #pod octal string beginning with a "0" or a limited subset of the symbolic mode use
  #pod by F</bin/chmod>.
  #pod
  #pod The symbolic mode must be a comma-delimited list of mode clauses.  Clauses must
  #pod match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
  #pod "perms" parameters for each clause.  Unlike F</bin/chmod>, all three parameters
  #pod are required for each clause, multiple ops are not allowed and permissions
  #pod C<stugoX> are not supported.  (See L<File::chmod> for more complex needs.)
  #pod
  #pod Current API available since 0.053.
  #pod
  #pod =cut
  
  sub chmod {
      my ( $self, $new_mode ) = @_;
  
      my $mode;
      if ( $new_mode =~ /\d/ ) {
          $mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
      }
      elsif ( $new_mode =~ /[=+-]/ ) {
          $mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
      }
      else {
          Carp::croak("Invalid mode argument '$new_mode' for chmod()");
      }
  
      CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
  
      return 1;
  }
  
  #pod =method copy
  #pod
  #pod     path("/tmp/foo.txt")->copy("/tmp/bar.txt");
  #pod
  #pod Copies the current path to the given destination using L<File::Copy>'s
  #pod C<copy> function. Upon success, returns the C<Path::Tiny> object for the
  #pod newly copied file.
  #pod
  #pod Current API available since 0.070.
  #pod
  #pod =cut
  
  # XXX do recursively for directories?
  sub copy {
      my ( $self, $dest ) = @_;
      require File::Copy;
      File::Copy::copy( $self->[PATH], $dest )
        or Carp::croak("copy failed for $self to $dest: $!");
  
      return -d $dest ? _path( $dest, $self->basename ) : _path($dest);
  }
  
  #pod =method digest
  #pod
  #pod     $obj = path("/tmp/foo.txt")->digest;        # SHA-256
  #pod     $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
  #pod     $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );
  #pod
  #pod Returns a hexadecimal digest for a file.  An optional hash reference of options may
  #pod be given.  The only option is C<chunk_size>.  If C<chunk_size> is given, that many
  #pod bytes will be read at a time.  If not provided, the entire file will be slurped
  #pod into memory to compute the digest.
  #pod
  #pod Any subsequent arguments are passed to the constructor for L<Digest> to select
  #pod an algorithm.  If no arguments are given, the default is SHA-256.
  #pod
  #pod Current API available since 0.056.
  #pod
  #pod =cut
  
  sub digest {
      my ( $self, @opts ) = @_;
      my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
      $args = _get_args( $args, qw/chunk_size/ );
      unshift @opts, 'SHA-256' unless @opts;
      require Digest;
      my $digest = Digest->new(@opts);
      if ( $args->{chunk_size} ) {
          my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
          my $buf;
          while (!eof($fh)) {
              my $rc = read $fh, $buf, $args->{chunk_size};
              $self->_throw('read') unless defined $rc;
              $digest->add($buf);
          }
      }
      else {
          $digest->add( $self->slurp_raw );
      }
      return $digest->hexdigest;
  }
  
  #pod =method dirname (deprecated)
  #pod
  #pod     $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
  #pod
  #pod Returns the directory portion you would get from calling
  #pod C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
  #pod parent directory portion.  Because L<File::Spec> is inconsistent, the result
  #pod might or might not have a trailing slash.  Because of this, this method is
  #pod B<deprecated>.
  #pod
  #pod A better, more consistently approach is likely C<< $path->parent->stringify >>,
  #pod which will not have a trailing slash except for a root directory.
  #pod
  #pod Deprecated in 0.056.
  #pod
  #pod =cut
  
  sub dirname {
      my ($self) = @_;
      $self->_splitpath unless defined $self->[DIR];
      return length $self->[DIR] ? $self->[DIR] : ".";
  }
  
  #pod =method edit, edit_raw, edit_utf8
  #pod
  #pod     path("foo.txt")->edit( \&callback, $options );
  #pod     path("foo.txt")->edit_utf8( \&callback );
  #pod     path("foo.txt")->edit_raw( \&callback );
  #pod
  #pod These are convenience methods that allow "editing" a file using a single
  #pod callback argument. They slurp the file using C<slurp>, place the contents
  #pod inside a localized C<$_> variable, call the callback function (without
  #pod arguments), and then write C<$_> (presumably mutated) back to the
  #pod file with C<spew>.
  #pod
  #pod An optional hash reference may be used to pass options.  The only option is
  #pod C<binmode>, which is passed to C<slurp> and C<spew>.
  #pod
  #pod C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
  #pod C<spew_*> methods.
  #pod
  #pod Current API available since 0.077.
  #pod
  #pod =cut
  
  sub edit {
      my $self = shift;
      my $cb   = shift;
      my $args = _get_args( shift, qw/binmode/ );
      Carp::croak("Callback for edit() must be a code reference")
        unless defined($cb) && ref($cb) eq 'CODE';
  
      local $_ =
        $self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
      $cb->();
      $self->spew( $args, $_ );
  
      return;
  }
  
  # this is done long-hand to benefit from slurp_utf8 optimizations
  sub edit_utf8 {
      my ( $self, $cb ) = @_;
      Carp::croak("Callback for edit_utf8() must be a code reference")
        unless defined($cb) && ref($cb) eq 'CODE';
  
      local $_ = $self->slurp_utf8;
      $cb->();
      $self->spew_utf8($_);
  
      return;
  }
  
  sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
  
  #pod =method edit_lines, edit_lines_utf8, edit_lines_raw
  #pod
  #pod     path("foo.txt")->edit_lines( \&callback, $options );
  #pod     path("foo.txt")->edit_lines_utf8( \&callback );
  #pod     path("foo.txt")->edit_lines_raw( \&callback );
  #pod
  #pod These are convenience methods that allow "editing" a file's lines using a
  #pod single callback argument.  They iterate over the file: for each line, the
  #pod line is put into a localized C<$_> variable, the callback function is
  #pod executed (without arguments) and then C<$_> is written to a temporary file.
  #pod When iteration is finished, the temporary file is atomically renamed over
  #pod the original.
  #pod
  #pod An optional hash reference may be used to pass options.  The only option is
  #pod C<binmode>, which is passed to the method that open handles for reading and
  #pod writing.
  #pod
  #pod C<edit_lines_raw> is like C<edit_lines> with a buffered C<binmode> of
  #pod C<:raw>.
  #pod
  #pod C<edit_lines_utf8> is like C<edit_lines> with a buffered C<binmode>
  #pod C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
  #pod L<PerlIO::utf8_strict>).
  #pod
  #pod Current API available since 0.077.
  #pod
  #pod =cut
  
  sub edit_lines {
      my $self = shift;
      my $cb   = shift;
      my $args = _get_args( shift, qw/binmode/ );
      Carp::croak("Callback for edit_lines() must be a code reference")
        unless defined($cb) && ref($cb) eq 'CODE';
  
      my $binmode = $args->{binmode};
      # get default binmode from caller's lexical scope (see "perldoc open")
      $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
  
      # writing needs to follow the link and create the tempfile in the same
      # dir for later atomic rename
      my $resolved_path = $self->_resolve_symlinks;
      my $temp          = $resolved_path->_replacement_path;
  
      my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
      my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
  
      local $_;
      while (! eof($in_fh) ) {
          defined( $_ = readline($in_fh) ) or $self->_throw('readline');
          $cb->();
          $temp_fh->print($_) or $self->_throw('print', $temp);
      }
  
      close $temp_fh or $self->_throw( 'close', $temp );
      close $in_fh or $self->_throw('close');
  
      return $temp->move($resolved_path);
  }
  
  sub edit_lines_raw { $_[2] = { binmode => ":raw" }; goto &edit_lines }
  
  sub edit_lines_utf8 {
      if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
          $_[2] = { binmode => ":raw:utf8_strict" };
      }
      else {
          $_[2] = { binmode => ":raw:encoding(UTF-8)" };
      }
      goto &edit_lines;
  }
  
  #pod =method exists, is_file, is_dir
  #pod
  #pod     if ( path("/tmp")->exists ) { ... }     # -e
  #pod     if ( path("/tmp")->is_dir ) { ... }     # -d
  #pod     if ( path("/tmp")->is_file ) { ... }    # -e && ! -d
  #pod
  #pod Implements file test operations, this means the file or directory actually has
  #pod to exist on the filesystem.  Until then, it's just a path.
  #pod
  #pod B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>.
  #pod C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
  #pod read just like files.
  #pod
  #pod Use C<-f> instead if you really mean to check for a plain file.
  #pod
  #pod Current API available since 0.053.
  #pod
  #pod =cut
  
  sub exists { -e $_[0]->[PATH] }
  
  sub is_file { -e $_[0]->[PATH] && !-d _ }
  
  sub is_dir { -d $_[0]->[PATH] }
  
  #pod =method filehandle
  #pod
  #pod     $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
  #pod     $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
  #pod     $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1  }, $mode, $binmode);
  #pod
  #pod Returns an open file handle.  The C<$mode> argument must be a Perl-style
  #pod read/write mode string ("<" ,">", ">>", etc.).  If a C<$binmode>
  #pod is given, it is set during the C<open> call.
  #pod
  #pod An optional hash reference may be used to pass options.
  #pod
  #pod The C<locked> option governs file locking; if true, handles opened for writing,
  #pod appending or read-write are locked with C<LOCK_EX>; otherwise, they are
  #pod locked with C<LOCK_SH>.  When using C<locked>, ">" or "+>" modes will delay
  #pod truncation until after the lock is acquired.
  #pod
  #pod The C<exclusive> option causes the open() call to fail if the file already
  #pod exists.  This corresponds to the O_EXCL flag to sysopen / open(2).
  #pod C<exclusive> implies C<locked> and will set it for you if you forget it.
  #pod
  #pod See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar.
  #pod
  #pod Current API available since 0.066.
  #pod
  #pod =cut
  
  # Note: must put binmode on open line, not subsequent binmode() call, so things
  # like ":unix" actually stop perlio/crlf from being added
  
  sub filehandle {
      my ( $self, @args ) = @_;
      my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
      $args = _get_args( $args, qw/locked exclusive/ );
      $args->{locked} = 1 if $args->{exclusive};
      my ( $opentype, $binmode ) = @args;
  
      $opentype = "<" unless defined $opentype;
      Carp::croak("Invalid file mode '$opentype'")
        unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
  
      $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $opentype, -1, 1 ) }
        unless defined $binmode;
      $binmode = "" unless defined $binmode;
  
      my ( $fh, $lock, $trunc );
      if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
          require Fcntl;
          # truncating file modes shouldn't truncate until lock acquired
          if ( grep { $opentype eq $_ } qw( > +> ) ) {
              # sysopen in write mode without truncation
              my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
              $flags |= Fcntl::O_CREAT();
              $flags |= Fcntl::O_EXCL() if $args->{exclusive};
              sysopen( $fh, $self->[PATH], $flags ) or $self->_throw("sysopen");
  
              # fix up the binmode since sysopen() can't specify layers like
              # open() and binmode() can't start with just :unix like open()
              if ( $binmode =~ s/^:unix// ) {
                  # eliminate pseudo-layers
                  binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
                  # strip off real layers until only :unix is left
                  while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
                      binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
                  }
              }
  
              # apply any remaining binmode layers
              if ( length $binmode ) {
                  binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
              }
  
              # ask for lock and truncation
              $lock  = Fcntl::LOCK_EX();
              $trunc = 1;
          }
          elsif ( $^O eq 'aix' && $opentype eq "<" ) {
              # AIX can only lock write handles, so upgrade to RW and LOCK_EX if
              # the file is writable; otherwise give up on locking.  N.B.
              # checking -w before open to determine the open mode is an
              # unavoidable race condition
              if ( -w $self->[PATH] ) {
                  $opentype = "+<";
                  $lock     = Fcntl::LOCK_EX();
              }
          }
          else {
              $lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
          }
      }
  
      unless ($fh) {
          my $mode = $opentype . $binmode;
          open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
      }
  
      do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
      do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
  
      return $fh;
  }
  
  #pod =method has_same_bytes
  #pod
  #pod     if ( path("foo.txt")->has_same_bytes("bar.txt") ) {
  #pod        # ...
  #pod     }
  #pod
  #pod This method returns true if both the invocant and the argument can be opened as
  #pod file handles and the handles contain the same bytes.  It returns false if their
  #pod contents differ.  If either can't be opened as a file (e.g. a directory or
  #pod non-existent file), the method throws an exception.  If both can be opened and
  #pod both have the same C<realpath>, the method returns true without scanning any
  #pod data.
  #pod
  #pod Current API available since 0.125.
  #pod
  #pod =cut
  
  sub has_same_bytes {
      my ($self, $other_path) = @_;
      my $other = _path($other_path);
  
      my $fh1 = $self->openr_raw({ locked => 1 });
      my $fh2 = $other->openr_raw({ locked => 1 });
  
      # check for directories
      if (-d $fh1) {
          $self->_throw('has_same_bytes', $self->[PATH], "directory not allowed");
      }
      if (-d $fh2) {
          $self->_throw('has_same_bytes', $other->[PATH], "directory not allowed");
      }
  
      # Now that handles are open, we know the inputs are readable files that
      # exist, so it's safe to compare via realpath
      if ($self->realpath eq $other->realpath) {
          return 1
      }
  
      # result is 0 for equal, 1 for unequal, -1 for error
      require File::Compare;
      my $res = File::Compare::compare($fh1, $fh2, 65536);
      if ($res < 0) {
          $self->_throw('has_same_bytes')
      }
  
      return $res == 0;
  }
  
  #pod =method is_absolute, is_relative
  #pod
  #pod     if ( path("/tmp")->is_absolute ) { ... }
  #pod     if ( path("/tmp")->is_relative ) { ... }
  #pod
  #pod Booleans for whether the path appears absolute or relative.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
  
  sub is_relative { substr( $_[0]->dirname, 0, 1 ) ne '/' }
  
  #pod =method is_rootdir
  #pod
  #pod     while ( ! $path->is_rootdir ) {
  #pod         $path = $path->parent;
  #pod         ...
  #pod     }
  #pod
  #pod Boolean for whether the path is the root directory of the volume.  I.e. the
  #pod C<dirname> is C<q[/]> and the C<basename> is C<q[]>.
  #pod
  #pod This works even on C<MSWin32> with drives and UNC volumes:
  #pod
  #pod     path("C:/")->is_rootdir;             # true
  #pod     path("//server/share/")->is_rootdir; #true
  #pod
  #pod Current API available since 0.038.
  #pod
  #pod =cut
  
  sub is_rootdir {
      my ($self) = @_;
      $self->_splitpath unless defined $self->[DIR];
      return $self->[DIR] eq '/' && $self->[FILE] eq '';
  }
  
  #pod =method iterator
  #pod
  #pod     $iter = path("/tmp")->iterator( \%options );
  #pod
  #pod Returns a code reference that walks a directory lazily.  Each invocation
  #pod returns a C<Path::Tiny> object or undef when the iterator is exhausted.
  #pod
  #pod     $iter = path("/tmp")->iterator;
  #pod     while ( $path = $iter->() ) {
  #pod         ...
  #pod     }
  #pod
  #pod The current and parent directory entries ("." and "..") will not
  #pod be included.
  #pod
  #pod If the C<recurse> option is true, the iterator will walk the directory
  #pod recursively, breadth-first.  If the C<follow_symlinks> option is also true,
  #pod directory links will be followed recursively.  There is no protection against
  #pod loops when following links. If a directory is not readable, it will not be
  #pod followed.
  #pod
  #pod The default is the same as:
  #pod
  #pod     $iter = path("/tmp")->iterator( {
  #pod         recurse         => 0,
  #pod         follow_symlinks => 0,
  #pod     } );
  #pod
  #pod For a more powerful, recursive iterator with built-in loop avoidance, see
  #pod L<Path::Iterator::Rule>.
  #pod
  #pod See also L</visit>.
  #pod
  #pod Current API available since 0.016.
  #pod
  #pod =cut
  
  sub iterator {
      my $self = shift;
      my $args = _get_args( shift, qw/recurse follow_symlinks/ );
      my @dirs = $self;
      my $current;
      return sub {
          my $next;
          while (@dirs) {
              if ( ref $dirs[0] eq 'Path::Tiny' ) {
                  if ( !-r $dirs[0] ) {
                      # Directory is missing or not readable, so skip it.  There
                      # is still a race condition possible between the check and
                      # the opendir, but we can't easily differentiate between
                      # error cases that are OK to skip and those that we want
                      # to be exceptions, so we live with the race and let opendir
                      # be fatal.
                      shift @dirs and next;
                  }
                  $current = $dirs[0];
                  my $dh;
                  opendir( $dh, $current->[PATH] )
                    or $self->_throw( 'opendir', $current->[PATH] );
                  $dirs[0] = $dh;
                  if ( -l $current->[PATH] && !$args->{follow_symlinks} ) {
                      # Symlink attack! It was a real dir, but is now a symlink!
                      # N.B. we check *after* opendir so the attacker has to win
                      # two races: replace dir with symlink before opendir and
                      # replace symlink with dir before -l check above
                      shift @dirs and next;
                  }
              }
              while ( defined( $next = readdir $dirs[0] ) ) {
                  next if $next eq '.' || $next eq '..';
                  my $path = $current->child($next);
                  push @dirs, $path
                    if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
                  return $path;
              }
              shift @dirs;
          }
          return;
      };
  }
  
  #pod =method lines, lines_raw, lines_utf8
  #pod
  #pod     @contents = path("/tmp/foo.txt")->lines;
  #pod     @contents = path("/tmp/foo.txt")->lines(\%options);
  #pod     @contents = path("/tmp/foo.txt")->lines_raw;
  #pod     @contents = path("/tmp/foo.txt")->lines_utf8;
  #pod
  #pod     @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
  #pod
  #pod Returns a list of lines from a file.  Optionally takes a hash-reference of
  #pod options.  Valid options are C<binmode>, C<count> and C<chomp>.
  #pod
  #pod If C<binmode> is provided, it will be set on the handle prior to reading.
  #pod
  #pod If a positive C<count> is provided, that many lines will be returned from the
  #pod start of the file.  If a negative C<count> is provided, the entire file will be
  #pod read, but only C<abs(count)> will be kept and returned.  If C<abs(count)>
  #pod exceeds the number of lines in the file, all lines will be returned.
  #pod
  #pod If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
  #pod C<LF>) will be removed from the lines returned.
  #pod
  #pod Because the return is a list, C<lines> in scalar context will return the number
  #pod of lines (and throw away the data).
  #pod
  #pod     $number_of_lines = path("/tmp/foo.txt")->lines;
  #pod
  #pod C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>.  We use C<:raw>
  #pod instead of C<:unix> so PerlIO buffering can manage reading by line.
  #pod
  #pod C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
  #pod (or C<:raw:utf8_strict> with L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
  #pod 0.58+ is installed, a raw, unbuffered UTF-8 slurp will be done and then the
  #pod lines will be split.  This is actually faster than relying on
  #pod IO layers, though a bit memory intensive.  If memory use is a
  #pod concern, consider C<openr_utf8> and iterating directly on the handle.
  #pod
  #pod See also L</slurp> if you want to load a file as a whole chunk.
  #pod
  #pod Current API available since 0.065.
  #pod
  #pod =cut
  
  sub lines {
      my $self    = shift;
      my $args    = _get_args( shift, qw/binmode chomp count/ );
      my $binmode = $args->{binmode};
      $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
      my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
      my $chomp = $args->{chomp};
      # XXX more efficient to read @lines then chomp(@lines) vs map?
      if ( $args->{count} ) {
          my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
          my $line;
          while ( !eof($fh) ) {
              defined( $line = readline($fh) ) or $self->_throw('readline');
  
              $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp;
              $result[ $counter++ ] = $line;
              # for positive count, terminate after right number of lines
              last if $counter == $args->{count};
              # for negative count, eventually wrap around in the result array
              $counter %= $mod;
          }
          # reorder results if full and wrapped somewhere in the middle
          splice( @result, 0, 0, splice( @result, $counter ) )
            if @result == $mod && $counter % $mod;
          return @result;
      }
      elsif ($chomp) {
          local $!;
          my @lines = map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic
          $self->_throw('readline') if $!;
          return @lines;
      }
      else {
          if ( wantarray ) {
              local $!;
              my @lines = <$fh>;
              $self->_throw('readline') if $!;
              return @lines;
          } else {
              local $!;
              my $count =()= <$fh>;
              $self->_throw('readline') if $!;
              return $count;
          }
      }
  }
  
  sub lines_raw {
      my $self = shift;
      my $args = _get_args( shift, qw/binmode chomp count/ );
      if ( $args->{chomp} && !$args->{count} ) {
          return split /\n/, slurp_raw($self);                    ## no critic
      }
      else {
          $args->{binmode} = ":raw";
          return lines( $self, $args );
      }
  }
  
  my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/;
  
  sub lines_utf8 {
      my $self = shift;
      my $args = _get_args( shift, qw/binmode chomp count/ );
      if (   ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
          && $args->{chomp}
          && !$args->{count} )
      {
          my $slurp = slurp_utf8($self);
          $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR
          return split $CRLF, $slurp, -1; ## no critic
      }
      elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
          $args->{binmode} = ":raw:utf8_strict";
          return lines( $self, $args );
      }
      else {
          $args->{binmode} = ":raw:encoding(UTF-8)";
          return lines( $self, $args );
      }
  }
  
  #pod =method mkdir
  #pod
  #pod     path("foo/bar/baz")->mkdir;
  #pod     path("foo/bar/baz")->mkdir( \%options );
  #pod
  #pod Like calling C<make_path> from L<File::Path>.  An optional hash reference
  #pod is passed through to C<make_path>.  Errors will be trapped and an exception
  #pod thrown.  Returns the the path object to facilitate chaining.
  #pod
  #pod B<NOTE>: unlike Perl's builtin C<mkdir>, this will create intermediate paths
  #pod similar to the Unix C<mkdir -p> command.  It will not error if applied to an
  #pod existing directory.
  #pod
  #pod Passing a defined argument I<other> than a hash reference is an error, and an
  #pod exception will be thrown.
  #pod
  #pod Current API available since 0.125.
  #pod
  #pod =cut
  
  sub mkdir {
      my ( $self, $args, @rest ) = @_;
  
      $args = {} unless defined $args;
      if (@rest || (defined $args && ref $args ne 'HASH')) {
          $self->_throw('mkdir', undef, "method argument was given, but was not a hash reference");
      }
  
      my $err;
  
      $args->{error} = \$err unless defined $args->{error};
      require File::Path;
      my @dirs;
      my $ok = eval {
          File::Path::make_path( $self->[PATH], $args );
          1;
      };
      if (!$ok) {
          $self->_throw('mkdir', $self->[PATH], "error creating path: $@");
      }
      if ( $err && @$err ) {
          my ( $file, $message ) = %{ $err->[0] };
          $self->_throw('mkdir', $file, $message);
      }
      return $self;
  }
  
  #pod =method mkpath (deprecated)
  #pod
  #pod Like calling C<mkdir>, but returns the list of directories created or an empty list if
  #pod the directories already exist, just like C<make_path>.
  #pod
  #pod Passing a defined argument I<other> than a hash reference is an error, and an
  #pod exception will be thrown.
  #pod
  #pod Deprecated in 0.125.
  #pod
  #pod =cut
  
  sub mkpath {
      my ( $self, $args, @rest ) = @_;
  
      $args = {} unless defined $args;
      if (@rest || (defined $args && ref $args ne 'HASH')) {
          $self->_throw('mkdir', undef, "method argument was given, but was not a hash reference");
      }
  
      my $err;
      $args->{error} = \$err unless defined $args->{error};
      require File::Path;
      my @dirs = File::Path::make_path( $self->[PATH], $args );
      if ( $err && @$err ) {
          my ( $file, $message ) = %{ $err->[0] };
          Carp::croak("mkpath failed for $file: $message");
      }
      return @dirs;
  }
  
  #pod =method move
  #pod
  #pod     path("foo.txt")->move("bar.txt");
  #pod
  #pod Moves the current path to the given destination using L<File::Copy>'s
  #pod C<move> function. Upon success, returns the C<Path::Tiny> object for the
  #pod newly moved file.
  #pod
  #pod If the destination already exists and is a directory, and the source is not a
  #pod directory, then the source file will be renamed into the directory
  #pod specified by the destination.
  #pod
  #pod If possible, move() will simply rename the file. Otherwise, it
  #pod copies the file to the new location and deletes the original. If an
  #pod error occurs during this copy-and-delete process, you may be left
  #pod with a (possibly partial) copy of the file under the destination
  #pod name.
  #pod
  #pod Current API available since 0.124. Prior versions used Perl's
  #pod -built-in (and less robust) L<rename|perlfunc/rename> function
  #pod and did not return an object.
  #pod
  #pod =cut
  
  sub move {
      my ( $self, $dest ) = @_;
      require File::Copy;
      File::Copy::move( $self->[PATH], $dest )
        or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" );
  
      return -d $dest ? _path( $dest, $self->basename ) : _path($dest);
  }
  
  #pod =method openr, openw, openrw, opena
  #pod
  #pod     $fh = path("foo.txt")->openr($binmode);  # read
  #pod     $fh = path("foo.txt")->openr_raw;
  #pod     $fh = path("foo.txt")->openr_utf8;
  #pod
  #pod     $fh = path("foo.txt")->openw($binmode);  # write
  #pod     $fh = path("foo.txt")->openw_raw;
  #pod     $fh = path("foo.txt")->openw_utf8;
  #pod
  #pod     $fh = path("foo.txt")->opena($binmode);  # append
  #pod     $fh = path("foo.txt")->opena_raw;
  #pod     $fh = path("foo.txt")->opena_utf8;
  #pod
  #pod     $fh = path("foo.txt")->openrw($binmode); # read/write
  #pod     $fh = path("foo.txt")->openrw_raw;
  #pod     $fh = path("foo.txt")->openrw_utf8;
  #pod
  #pod Returns a file handle opened in the specified mode.  The C<openr> style methods
  #pod take a single C<binmode> argument.  All of the C<open*> methods have
  #pod C<open*_raw> and C<open*_utf8> equivalents that use buffered I/O layers C<:raw>
  #pod and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
  #pod L<PerlIO::utf8_strict>).
  #pod
  #pod An optional hash reference may be used to pass options.  The only option is
  #pod C<locked>.  If true, handles opened for writing, appending or read-write are
  #pod locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.
  #pod
  #pod     $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
  #pod
  #pod See L</filehandle> for more on locking.
  #pod
  #pod Current API available since 0.011.
  #pod
  #pod =cut
  
  # map method names to corresponding open mode
  my %opens = (
      opena  => ">>",
      openr  => "<",
      openw  => ">",
      openrw => "+<"
  );
  
  while ( my ( $k, $v ) = each %opens ) {
      no strict 'refs';
      # must check for lexical IO mode hint
      *{$k} = sub {
          my ( $self, @args ) = @_;
          my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
          $args = _get_args( $args, qw/locked/ );
          my ($binmode) = @args;
          $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) }
            unless defined $binmode;
          $self->filehandle( $args, $v, $binmode );
      };
      *{ $k . "_raw" } = sub {
          my ( $self, @args ) = @_;
          my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
          $args = _get_args( $args, qw/locked/ );
          $self->filehandle( $args, $v, ":raw" );
      };
      *{ $k . "_utf8" } = sub {
          my ( $self, @args ) = @_;
          my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
          $args = _get_args( $args, qw/locked/ );
          my $layer;
          if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
              $layer = ":raw:utf8_strict";
          }
          else {
              $layer = ":raw:encoding(UTF-8)";
          }
          $self->filehandle( $args, $v, $layer );
      };
  }
  
  #pod =method parent
  #pod
  #pod     $parent = path("foo/bar/baz")->parent; # foo/bar
  #pod     $parent = path("foo/wibble.txt")->parent; # foo
  #pod
  #pod     $parent = path("foo/bar/baz")->parent(2); # foo
  #pod
  #pod Returns a C<Path::Tiny> object corresponding to the parent directory of the
  #pod original directory or file. An optional positive integer argument is the number
  #pod of parent directories upwards to return.  C<parent> by itself is equivalent to
  #pod C<parent(1)>.
  #pod
  #pod Current API available since 0.014.
  #pod
  #pod =cut
  
  # XXX this is ugly and coverage is incomplete.  I think it's there for windows
  # so need to check coverage there and compare
  sub parent {
      my ( $self, $level ) = @_;
      $level = 1 unless defined $level && $level > 0;
      $self->_splitpath unless defined $self->[FILE];
      my $parent;
      if ( length $self->[FILE] ) {
          if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) {
              $parent = _path( $self->[PATH] . "/.." );
          }
          else {
              $parent = _path( _non_empty( $self->[VOL] . $self->[DIR] ) );
          }
      }
      elsif ( length $self->[DIR] ) {
          # because of symlinks, any internal updir requires us to
          # just add more updirs at the end
          if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) {
              $parent = _path( $self->[VOL] . $self->[DIR] . "/.." );
          }
          else {
              ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
              $parent = _path( $self->[VOL] . $dir );
          }
      }
      else {
          $parent = _path( _non_empty( $self->[VOL] ) );
      }
      return $level == 1 ? $parent : $parent->parent( $level - 1 );
  }
  
  sub _non_empty {
      my ($string) = shift;
      return ( ( defined($string) && length($string) ) ? $string : "." );
  }
  
  #pod =method realpath
  #pod
  #pod     $real = path("/baz/foo/../bar")->realpath;
  #pod     $real = path("foo/../bar")->realpath;
  #pod
  #pod Returns a new C<Path::Tiny> object with all symbolic links and upward directory
  #pod parts resolved using L<Cwd>'s C<realpath>.  Compared to C<absolute>, this is
  #pod more expensive as it must actually consult the filesystem.
  #pod
  #pod If the parent path can't be resolved (e.g. if it includes directories that
  #pod don't exist), an exception will be thrown:
  #pod
  #pod     $real = path("doesnt_exist/foo")->realpath; # dies
  #pod
  #pod However, if the parent path exists and only the last component (e.g. filename)
  #pod doesn't exist, the realpath will be the realpath of the parent plus the
  #pod non-existent last component:
  #pod
  #pod     $real = path("./aasdlfasdlf")->realpath; # works
  #pod
  #pod The underlying L<Cwd> module usually worked this way on Unix, but died on
  #pod Windows (and some Unixes) if the full path didn't exist.  As of version 0.064,
  #pod it's safe to use anywhere.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  # Win32 and some Unixes need parent path resolved separately so realpath
  # doesn't throw an error resolving non-existent basename
  sub realpath {
      my $self = shift;
      $self = $self->_resolve_symlinks;
      require Cwd;
      $self->_splitpath if !defined $self->[FILE];
      my $check_parent =
        length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
      my $realpath = eval {
          # pure-perl Cwd can carp
          local $SIG{__WARN__} = sub { };
          Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] );
      };
      # parent realpath must exist; not all Cwd::realpath will error if it doesn't
      $self->_throw("resolving realpath")
        unless defined $realpath && length $realpath && -e $realpath;
      return ( $check_parent ? _path( $realpath, $self->[FILE] ) : _path($realpath) );
  }
  
  #pod =method relative
  #pod
  #pod     $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
  #pod
  #pod Returns a C<Path::Tiny> object with a path relative to a new base path
  #pod given as an argument.  If no argument is given, the current directory will
  #pod be used as the new base path.
  #pod
  #pod If either path is already relative, it will be made absolute based on the
  #pod current directly before determining the new relative path.
  #pod
  #pod The algorithm is roughly as follows:
  #pod
  #pod =for :list
  #pod * If the original and new base path are on different volumes, an exception
  #pod   will be thrown.
  #pod * If the original and new base are identical, the relative path is C<".">.
  #pod * If the new base subsumes the original, the relative path is the original
  #pod   path with the new base chopped off the front
  #pod * If the new base does not subsume the original, a common prefix path is
  #pod   determined (possibly the root directory) and the relative path will
  #pod   consist of updirs (C<"..">) to reach the common prefix, followed by the
  #pod   original path less the common prefix.
  #pod
  #pod Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
  #pod on a common prefix takes into account symlinks that could affect the updir
  #pod process.  Given an original path "/A/B" and a new base "/A/C",
  #pod (where "A", "B" and "C" could each have multiple path components):
  #pod
  #pod =for :list
  #pod * Symlinks in "A" don't change the result unless the last component of A is
  #pod   a symlink and the first component of "C" is an updir.
  #pod * Symlinks in "B" don't change the result and will exist in the result as
  #pod   given.
  #pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
  #pod   account the possibility that not all path components might exist on the
  #pod   filesystem.
  #pod
  #pod Current API available since 0.001.  New algorithm (that accounts for
  #pod symlinks) available since 0.079.
  #pod
  #pod =cut
  
  sub relative {
      my ( $self, $base ) = @_;
      $base = _path( defined $base && length $base ? $base : '.' );
  
      # relative paths must be converted to absolute first
      $self = $self->absolute if $self->is_relative;
      $base = $base->absolute if $base->is_relative;
  
      # normalize volumes if they exist
      $self = $self->absolute if !length $self->volume && length $base->volume;
      $base = $base->absolute if length $self->volume  && !length $base->volume;
  
      # can't make paths relative across volumes
      if ( !_same( $self->volume, $base->volume ) ) {
          Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
      }
  
      # if same absolute path, relative is current directory
      return _path(".") if _same( $self->[PATH], $base->[PATH] );
  
      # if base is a prefix of self, chop prefix off self
      if ( $base->subsumes($self) ) {
          $base = "" if $base->is_rootdir;
          my $relative = "$self";
          $relative =~ s{\A\Q$base/}{};
          return _path(".", $relative);
      }
  
      # base is not a prefix, so must find a common prefix (even if root)
      my ( @common, @self_parts, @base_parts );
      @base_parts = split /\//, $base->_just_filepath;
  
      # if self is rootdir, then common directory is root (shown as empty
      # string for later joins); otherwise, must be computed from path parts.
      if ( $self->is_rootdir ) {
          @common = ("");
          shift @base_parts;
      }
      else {
          @self_parts = split /\//, $self->_just_filepath;
  
          while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
              push @common, shift @base_parts;
              shift @self_parts;
          }
      }
  
      # if there are any symlinks from common to base, we have a problem, as
      # you can't guarantee that updir from base reaches the common prefix;
      # we must resolve symlinks and try again; likewise, any updirs are
      # a problem as it throws off calculation of updirs needed to get from
      # self's path to the common prefix.
      if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
          return $self->relative($new_base);
      }
  
      # otherwise, symlinks in common or from common to A don't matter as
      # those don't involve updirs
      my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
      return _path(@new_path);
  }
  
  sub _just_filepath {
      my $self     = shift;
      my $self_vol = $self->volume;
      return "$self" if !length $self_vol;
  
      ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
  
      return $self_path;
  }
  
  sub _resolve_between {
      my ( $self, $common, $base ) = @_;
      my $path = $self->volume . join( "/", @$common );
      my $changed = 0;
      for my $p (@$base) {
          $path .= "/$p";
          if ( $p eq '..' ) {
              $changed = 1;
              if ( -e $path ) {
                  $path = _path($path)->realpath->[PATH];
              }
              else {
                  $path =~ s{/[^/]+/..\z}{/};
              }
          }
          if ( -l $path ) {
              $changed = 1;
              $path    = _path($path)->realpath->[PATH];
          }
      }
      return $changed ? _path($path) : undef;
  }
  
  #pod =method remove
  #pod
  #pod     path("foo.txt")->remove;
  #pod
  #pod This is just like C<unlink>, except for its error handling: if the path does
  #pod not exist, it returns false; if deleting the file fails, it throws an
  #pod exception.
  #pod
  #pod Current API available since 0.012.
  #pod
  #pod =cut
  
  sub remove {
      my $self = shift;
  
      return 0 if !-e $self->[PATH] && !-l $self->[PATH];
  
      return unlink( $self->[PATH] ) || $self->_throw('unlink');
  }
  
  #pod =method remove_tree
  #pod
  #pod     # directory
  #pod     path("foo/bar/baz")->remove_tree;
  #pod     path("foo/bar/baz")->remove_tree( \%options );
  #pod     path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
  #pod
  #pod Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
  #pod An optional hash reference is passed through to C<remove_tree>.  Errors will be
  #pod trapped and an exception thrown.  Returns the number of directories deleted,
  #pod just like C<remove_tree>.
  #pod
  #pod If you want to remove a directory only if it is empty, use the built-in
  #pod C<rmdir> function instead.
  #pod
  #pod     rmdir path("foo/bar/baz/");
  #pod
  #pod Current API available since 0.013.
  #pod
  #pod Passing a defined argument I<other> than a hash reference is an error, and an
  #pod exception will be thrown.
  #pod
  #pod =cut
  
  sub remove_tree {
      my ( $self, $args, @rest ) = @_;
  
      $args = {} unless defined $args;
      if (@rest || (defined $args && ref $args ne 'HASH')) {
          $self->_throw('mkdir', undef, "method argument was given, but was not a hash reference");
      }
  
      return 0 if !-e $self->[PATH] && !-l $self->[PATH];
  
      my $err;
      $args->{error} = \$err unless defined $args->{error};
      $args->{safe}  = 1     unless defined $args->{safe};
      require File::Path;
      my $count = File::Path::remove_tree( $self->[PATH], $args );
  
      if ( $err && @$err ) {
          my ( $file, $message ) = %{ $err->[0] };
          Carp::croak("remove_tree failed for $file: $message");
      }
      return $count;
  }
  
  #pod =method sibling
  #pod
  #pod     $foo = path("/tmp/foo.txt");
  #pod     $sib = $foo->sibling("bar.txt");        # /tmp/bar.txt
  #pod     $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
  #pod
  #pod Returns a new C<Path::Tiny> object relative to the parent of the original.
  #pod This is slightly more efficient than C<< $path->parent->child(...) >>.
  #pod
  #pod Current API available since 0.058.
  #pod
  #pod =cut
  
  sub sibling {
      my $self = shift;
      return _path( $self->parent->[PATH], @_ );
  }
  
  #pod =method size, size_human
  #pod
  #pod     my $p = path("foo"); # with size 1025 bytes
  #pod
  #pod     $p->size;                            # "1025"
  #pod     $p->size_human;                      # "1.1 K"
  #pod     $p->size_human( {format => "iec"} ); # "1.1 KiB"
  #pod
  #pod Returns the size of a file.  The C<size> method is just a wrapper around C<-s>.
  #pod
  #pod The C<size_human> method provides a human-readable string similar to
  #pod C<ls -lh>.  Like C<ls>, it rounds upwards and provides one decimal place for
  #pod single-digit sizes and no decimal places for larger sizes.  The only available
  #pod option is C<format>, which has three valid values:
  #pod
  #pod =for :list
  #pod * 'ls' (the default): base-2 sizes, with C<ls> style single-letter suffixes (K, M, etc.)
  #pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.)
  #pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.)
  #pod
  #pod If C<-s> would return C<undef>, C<size_human> returns the empty string.
  #pod
  #pod Current API available since 0.122.
  #pod
  #pod =cut
  
  sub size { -s $_[0]->[PATH] }
  
  my %formats = (
      'ls'  => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ],
      'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ],
      'si'  => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ],
  );
  
  sub _formats { return $formats{$_[0]} }
  
  sub size_human {
      my $self     = shift;
      my $args     = _get_args( shift, qw/format/ );
      my $format   = defined $args->{format} ? $args->{format} : "ls";
      my $fmt_opts = $formats{$format}
        or Carp::croak("Invalid format '$format' for size_human()");
      my $size = -s $self->[PATH];
      return defined $size ? _human_size( $size, @$fmt_opts ) : "";
  }
  
  sub _ceil {
      return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1);
  }
  
  sub _human_size {
      my ( $size, $base, $log_base, $suffixes ) = @_;
      return "0" if $size == 0;
  
      my $mag = int( log($size) / $log_base );
      $size /= $base**$mag;
      $size =
          $mag == 0               ? $size
        : length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10
        :                             _ceil($size);
      if ( $size >= $base ) {
          $size /= $base;
          $mag++;
      }
  
      my $fmt = ( $mag == 0 || length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s";
      return sprintf( $fmt, $size, $suffixes->[$mag] );
  }
  
  #pod =method slurp, slurp_raw, slurp_utf8
  #pod
  #pod     $data = path("foo.txt")->slurp;
  #pod     $data = path("foo.txt")->slurp( {binmode => ":raw"} );
  #pod     $data = path("foo.txt")->slurp_raw;
  #pod     $data = path("foo.txt")->slurp_utf8;
  #pod
  #pod Reads file contents into a scalar.  Takes an optional hash reference which may
  #pod be used to pass options.  The only available option is C<binmode>, which is
  #pod passed to C<binmode()> on the handle used for reading.
  #pod
  #pod C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
  #pod a fast, unbuffered, raw read.
  #pod
  #pod C<slurp_utf8> is like C<slurp> with a C<binmode> of
  #pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
  #pod L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, a
  #pod unbuffered, raw slurp will be done instead and the result decoded with
  #pod C<Unicode::UTF8>. This is just as strict and is roughly an order of
  #pod magnitude faster than using C<:encoding(UTF-8)>.
  #pod
  #pod B<Note>: C<slurp> and friends lock the filehandle before slurping.  If
  #pod you plan to slurp from a file created with L<File::Temp>, be sure to
  #pod close other handles or open without locking to avoid a deadlock:
  #pod
  #pod     my $tempfile = File::Temp->new(EXLOCK => 0);
  #pod     my $guts = path($tempfile)->slurp;
  #pod
  #pod See also L</lines> if you want to slurp a file into a line array.
  #pod
  #pod Current API available since 0.004.
  #pod
  #pod =cut
  
  sub slurp {
      my $self    = shift;
      my $args    = _get_args( shift, qw/binmode/ );
      my $binmode = $args->{binmode};
      $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
      my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
      if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
          and my $size = -s $fh )
      {
          my $buf;
          my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell
          $self->_throw('read') unless defined $rc;
          return $buf;
      }
      else {
          local $/;
          my $buf = scalar <$fh>;
          $self->_throw('read') unless defined $buf;
          return $buf;
      }
  }
  
  sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
  
  sub slurp_utf8 {
      if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
          return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
      }
      elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
          $_[1] = { binmode => ":unix:utf8_strict" };
          goto &slurp;
      }
      else {
          $_[1] = { binmode => ":unix:encoding(UTF-8)" };
          goto &slurp;
      }
  }
  
  #pod =method spew, spew_raw, spew_utf8
  #pod
  #pod     path("foo.txt")->spew(@data);
  #pod     path("foo.txt")->spew(\@data);
  #pod     path("foo.txt")->spew({binmode => ":raw"}, @data);
  #pod     path("foo.txt")->spew_raw(@data);
  #pod     path("foo.txt")->spew_utf8(@data);
  #pod
  #pod Writes data to a file atomically.  The file is written to a temporary file in
  #pod the same directory, then renamed over the original.  An optional hash reference
  #pod may be used to pass options.  The only option is C<binmode>, which is passed to
  #pod C<binmode()> on the handle used for writing.
  #pod
  #pod C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
  #pod unbuffered, raw write.
  #pod
  #pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
  #pod (or C<:unix:utf8_strict> with L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
  #pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data
  #pod encoded with C<Unicode::UTF8>.
  #pod
  #pod B<NOTE>: because the file is written to a temporary file and then renamed, the
  #pod new file will wind up with permissions based on your current umask.  This is a
  #pod feature to protect you from a race condition that would otherwise give
  #pod different permissions than you might expect.  If you really want to keep the
  #pod original mode flags, use L</append> with the C<truncate> option.
  #pod
  #pod Current API available since 0.011.
  #pod
  #pod =cut
  
  sub spew {
      my ( $self, @data ) = @_;
      my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
      $args = _get_args( $args, qw/binmode/ );
      my $binmode = $args->{binmode};
      # get default binmode from caller's lexical scope (see "perldoc open")
      $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
  
      # writing needs to follow the link and create the tempfile in the same
      # dir for later atomic rename
      my $resolved_path = $self->_resolve_symlinks;
      my $temp          = $resolved_path->_replacement_path;
  
      my $fh;
      my $ok = eval { $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode ); 1 };
      if (!$ok) {
          my $msg = ref($@) eq 'Path::Tiny::Error'
              ? "error opening temp file '$@->{file}' for atomic write: $@->{err}"
              : "error opening temp file for atomic write: $@";
          $self->_throw('spew', $self->[PATH], $msg);
      }
      print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or $self->_throw('print', $temp->[PATH]);
      close $fh or $self->_throw( 'close', $temp->[PATH] );
  
      return $temp->move($resolved_path);
  }
  
  sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
  
  sub spew_utf8 {
      if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
          my $self = shift;
          spew(
              $self,
              { binmode => ":unix" },
              map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
          );
      }
      elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
          splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
          goto &spew;
      }
      else {
          splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
          goto &spew;
      }
  }
  
  #pod =method stat, lstat
  #pod
  #pod     $stat = path("foo.txt")->stat;
  #pod     $stat = path("/some/symlink")->lstat;
  #pod
  #pod Like calling C<stat> or C<lstat> from L<File::stat>.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  # XXX break out individual stat() components as subs?
  sub stat {
      my $self = shift;
      require File::stat;
      return File::stat::stat( $self->[PATH] ) || $self->_throw('stat');
  }
  
  sub lstat {
      my $self = shift;
      require File::stat;
      return File::stat::lstat( $self->[PATH] ) || $self->_throw('lstat');
  }
  
  #pod =method stringify
  #pod
  #pod     $path = path("foo.txt");
  #pod     say $path->stringify; # same as "$path"
  #pod
  #pod Returns a string representation of the path.  Unlike C<canonpath>, this method
  #pod returns the path standardized with Unix-style C</> directory separators.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  sub stringify { $_[0]->[PATH] =~ /^~/ ? './' . $_[0]->[PATH] : $_[0]->[PATH] }
  
  #pod =method subsumes
  #pod
  #pod     path("foo/bar")->subsumes("foo/bar/baz"); # true
  #pod     path("/foo/bar")->subsumes("/foo/baz");   # false
  #pod
  #pod Returns true if the first path is a prefix of the second path at a directory
  #pod boundary.
  #pod
  #pod This B<does not> resolve parent directory entries (C<..>) or symlinks:
  #pod
  #pod     path("foo/bar")->subsumes("foo/bar/../baz"); # true
  #pod
  #pod If such things are important to you, ensure that both paths are resolved to
  #pod the filesystem with C<realpath>:
  #pod
  #pod     my $p1 = path("foo/bar")->realpath;
  #pod     my $p2 = path("foo/bar/../baz")->realpath;
  #pod     if ( $p1->subsumes($p2) ) { ... }
  #pod
  #pod Current API available since 0.048.
  #pod
  #pod =cut
  
  sub subsumes {
      my $self = shift;
      Carp::croak("subsumes() requires a defined, positive-length argument")
        unless defined $_[0];
      my $other = _path(shift);
  
      # normalize absolute vs relative
      if ( $self->is_absolute && !$other->is_absolute ) {
          $other = $other->absolute;
      }
      elsif ( $other->is_absolute && !$self->is_absolute ) {
          $self = $self->absolute;
      }
  
      # normalize volume vs non-volume; do this after absolute path
      # adjustments above since that might add volumes already
      if ( length $self->volume && !length $other->volume ) {
          $other = $other->absolute;
      }
      elsif ( length $other->volume && !length $self->volume ) {
          $self = $self->absolute;
      }
  
      if ( $self->[PATH] eq '.' ) {
          return !!1; # cwd subsumes everything relative
      }
      elsif ( $self->is_rootdir ) {
          # a root directory ("/", "c:/") already ends with a separator
          return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
      }
      else {
          # exact match or prefix breaking at a separator
          return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/|\z)};
      }
  }
  
  #pod =method touch
  #pod
  #pod     path("foo.txt")->touch;
  #pod     path("foo.txt")->touch($epoch_secs);
  #pod
  #pod Like the Unix C<touch> utility.  Creates the file if it doesn't exist, or else
  #pod changes the modification and access times to the current time.  If the first
  #pod argument is the epoch seconds then it will be used.
  #pod
  #pod Returns the path object so it can be easily chained with other methods:
  #pod
  #pod     # won't die if foo.txt doesn't exist
  #pod     $content = path("foo.txt")->touch->slurp;
  #pod
  #pod Current API available since 0.015.
  #pod
  #pod =cut
  
  sub touch {
      my ( $self, $epoch ) = @_;
      if ( !-e $self->[PATH] ) {
          my $fh = $self->openw;
          close $fh or $self->_throw('close');
      }
      if ( defined $epoch ) {
          utime $epoch, $epoch, $self->[PATH]
            or $self->_throw("utime ($epoch)");
      }
      else {
          # literal undef prevents warnings :-(
          utime undef, undef, $self->[PATH]
            or $self->_throw("utime ()");
      }
      return $self;
  }
  
  #pod =method touchpath
  #pod
  #pod     path("bar/baz/foo.txt")->touchpath;
  #pod
  #pod Combines C<mkdir> and C<touch>.  Creates the parent directory if it doesn't exist,
  #pod before touching the file.  Returns the path object like C<touch> does.
  #pod
  #pod If you need to pass options, use C<mkdir> and C<touch> separately:
  #pod
  #pod     path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs);
  #pod
  #pod Current API available since 0.022.
  #pod
  #pod =cut
  
  sub touchpath {
      my ($self) = @_;
      my $parent = $self->parent;
      $parent->mkdir unless $parent->exists;
      $self->touch;
  }
  
  #pod =method visit
  #pod
  #pod     path("/tmp")->visit( \&callback, \%options );
  #pod
  #pod Executes a callback for each child of a directory.  It returns a hash
  #pod reference with any state accumulated during iteration.
  #pod
  #pod The options are the same as for L</iterator> (which it uses internally):
  #pod C<recurse> and C<follow_symlinks>.  Both default to false.
  #pod
  #pod The callback function will receive a C<Path::Tiny> object as the first argument
  #pod and a hash reference to accumulate state as the second argument.  For example:
  #pod
  #pod     # collect files sizes
  #pod     my $sizes = path("/tmp")->visit(
  #pod         sub {
  #pod             my ($path, $state) = @_;
  #pod             return if $path->is_dir;
  #pod             $state->{$path} = -s $path;
  #pod         },
  #pod         { recurse => 1 }
  #pod     );
  #pod
  #pod For convenience, the C<Path::Tiny> object will also be locally aliased as the
  #pod C<$_> global variable:
  #pod
  #pod     # print paths matching /foo/
  #pod     path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
  #pod
  #pod If the callback returns a B<reference> to a false scalar value, iteration will
  #pod terminate.  This is not the same as "pruning" a directory search; this just
  #pod stops all iteration and returns the state hash reference.
  #pod
  #pod     # find up to 10 files larger than 100K
  #pod     my $files = path("/tmp")->visit(
  #pod         sub {
  #pod             my ($path, $state) = @_;
  #pod             $state->{$path}++ if -s $path > 102400
  #pod             return \0 if keys %$state == 10;
  #pod         },
  #pod         { recurse => 1 }
  #pod     );
  #pod
  #pod If you want more flexible iteration, use a module like L<Path::Iterator::Rule>.
  #pod
  #pod Current API available since 0.062.
  #pod
  #pod =cut
  
  sub visit {
      my $self = shift;
      my $cb   = shift;
      my $args = _get_args( shift, qw/recurse follow_symlinks/ );
      Carp::croak("Callback for visit() must be a code reference")
        unless defined($cb) && ref($cb) eq 'CODE';
      my $next  = $self->iterator($args);
      my $state = {};
      while ( my $file = $next->() ) {
          local $_ = $file;
          my $r = $cb->( $file, $state );
          last if ref($r) eq 'SCALAR' && !$$r;
      }
      return $state;
  }
  
  #pod =method volume
  #pod
  #pod     $vol = path("/tmp/foo.txt")->volume;   # ""
  #pod     $vol = path("C:/tmp/foo.txt")->volume; # "C:"
  #pod
  #pod Returns the volume portion of the path.  This is equivalent
  #pod to what L<File::Spec> would give from C<splitpath> and thus
  #pod usually is the empty string on Unix-like operating systems or the
  #pod drive letter for an absolute path on C<MSWin32>.
  #pod
  #pod Current API available since 0.001.
  #pod
  #pod =cut
  
  sub volume {
      my ($self) = @_;
      $self->_splitpath unless defined $self->[VOL];
      return $self->[VOL];
  }
  
  package Path::Tiny::Error;
  
  our @CARP_NOT = qw/Path::Tiny/;
  
  use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
  
  sub throw {
      my ( $class, $op, $file, $err ) = @_;
      chomp( my $trace = Carp::shortmess );
      my $msg = "Error $op on '$file': $err$trace\n";
      die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
  }
  
  1;
  
  
  # vim: ts=4 sts=4 sw=4 et:
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Path::Tiny - File path utility
  
  =head1 VERSION
  
  version 0.148
  
  =head1 SYNOPSIS
  
    use Path::Tiny;
  
    # Creating Path::Tiny objects
  
    my $dir = path("/tmp");
    my $foo = path("foo.txt");
  
    my $subdir = $dir->child("foo");
    my $bar = $subdir->child("bar.txt");
  
    # Stringifies as cleaned up path
  
    my $file = path("./foo.txt");
    print $file; # "foo.txt"
  
    # Reading files
  
    my $guts = $file->slurp;
       $guts = $file->slurp_utf8;
  
    my @lines = $file->lines;
       @lines = $file->lines_utf8;
  
    my ($head) = $file->lines( {count => 1} );
    my ($tail) = $file->lines( {count => -1} );
  
    # Writing files
  
    $bar->spew( @data );
    $bar->spew_utf8( @data );
  
    # Reading directories
  
    for ( $dir->children ) { ... }
  
    my $iter = $dir->iterator;
    while ( my $next = $iter->() ) { ... }
  
  =head1 DESCRIPTION
  
  This module provides a small, fast utility for working with file paths.  It is
  friendlier to use than L<File::Spec> and provides easy access to functions from
  several other core file handling modules.  It aims to be smaller and faster
  than many alternatives on CPAN, while helping people do many common things in
  consistent and less error-prone ways.
  
  Path::Tiny does not try to work for anything except Unix-like and Win32
  platforms.  Even then, it might break if you try something particularly obscure
  or tortuous.  (Quick!  What does this mean:
  C<< ///../../..//./././a//b/.././c/././ >>?  And how does it differ on Win32?)
  
  All paths are forced to have Unix-style forward slashes.  Stringifying
  the object gives you back the path (after some clean up).
  
  File input/output methods C<flock> handles before reading or writing,
  as appropriate (if supported by the platform and/or filesystem).
  
  The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw
  mode.  On Windows, that means they will not have CRLF translation from the
  C<:crlf> IO layer.  Installing L<Unicode::UTF8> 0.58 or later will speed up
  C<*_utf8> situations in many cases and is highly recommended.
  Alternatively, installing L<PerlIO::utf8_strict> 0.003 or later will be
  used in place of the default C<:encoding(UTF-8)>.
  
  This module depends heavily on PerlIO layers for correct operation and thus
  requires Perl 5.008001 or later.
  
  =head1 CONSTRUCTORS
  
  =head2 path
  
      $path = path("foo/bar");
      $path = path("/tmp", "file.txt"); # list
      $path = path(".");                # cwd
  
  Constructs a C<Path::Tiny> object.  It doesn't matter if you give a file or
  directory path.  It's still up to you to call directory-like methods only on
  directories and file-like methods only on files.  This function is exported
  automatically by default.
  
  The first argument must be defined and have non-zero length or an exception
  will be thrown.  This prevents subtle, dangerous errors with code like
  C<< path( maybe_undef() )->remove_tree >>.
  
  B<DEPRECATED>: If and only if the B<first> character of the B<first> argument
  to C<path> is a tilde ('~'), then tilde replacement will be applied to the
  first path segment. A single tilde will be replaced with C<glob('~')> and a
  tilde followed by a username will be replaced with output of
  C<glob('~username')>. B<No other method does tilde expansion on its arguments>.
  See L</Tilde expansion (deprecated)> for more.
  
  On Windows, if the path consists of a drive identifier without a path component
  (C<C:> or C<D:>), it will be expanded to the absolute path of the current
  directory on that volume using C<Cwd::getdcwd()>.
  
  If called with a single C<Path::Tiny> argument, the original is returned unless
  the original is holding a temporary file or directory reference in which case a
  stringified copy is made.
  
      $path = path("foo/bar");
      $temp = Path::Tiny->tempfile;
  
      $p2 = path($path); # like $p2 = $path
      $t2 = path($temp); # like $t2 = path( "$temp" )
  
  This optimizes copies without proliferating references unexpectedly if a copy is
  made by code outside your control.
  
  Current API available since 0.017.
  
  =head2 new
  
      $path = Path::Tiny->new("foo/bar");
  
  This is just like C<path>, but with method call overhead.  (Why would you
  do that?)
  
  Current API available since 0.001.
  
  =head2 cwd
  
      $path = Path::Tiny->cwd; # path( Cwd::getcwd )
      $path = cwd; # optional export
  
  Gives you the absolute path to the current directory as a C<Path::Tiny> object.
  This is slightly faster than C<< path(".")->absolute >>.
  
  C<cwd> may be exported on request and used as a function instead of as a
  method.
  
  Current API available since 0.018.
  
  =head2 rootdir
  
      $path = Path::Tiny->rootdir; # /
      $path = rootdir;             # optional export 
  
  Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too
  picky for C<path("/")>.
  
  C<rootdir> may be exported on request and used as a function instead of as a
  method.
  
  Current API available since 0.018.
  
  =head2 tempfile, tempdir
  
      $temp = Path::Tiny->tempfile( @options );
      $temp = Path::Tiny->tempdir( @options );
      $temp = $dirpath->tempfile( @options );
      $temp = $dirpath->tempdir( @options );
      $temp = tempfile( @options ); # optional export
      $temp = tempdir( @options );  # optional export
  
  C<tempfile> passes the options to C<< File::Temp->new >> and returns a
  C<Path::Tiny> object with the file name.  The C<TMPDIR> option will be enabled
  by default, but you can override that by passing C<< TMPDIR => 0 >> along with
  the options.  (If you use an absolute C<TEMPLATE> option, you will want to
  disable C<TMPDIR>.)
  
  The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
  destroyed, the C<File::Temp> object will be as well.
  
  C<File::Temp> annoyingly requires you to specify a custom template in slightly
  different ways depending on which function or method you call, but
  C<Path::Tiny> lets you ignore that and can take either a leading template or a
  C<TEMPLATE> option and does the right thing.
  
      $temp = Path::Tiny->tempfile( "customXXXXXXXX" );             # ok
      $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
  
  The tempfile path object will be normalized to have an absolute path, even if
  created in a relative directory using C<DIR>.  If you want it to have
  the C<realpath> instead, pass a leading options hash like this:
  
      $real_temp = tempfile({realpath => 1}, @options);
  
  C<tempdir> is just like C<tempfile>, except it calls
  C<< File::Temp->newdir >> instead.
  
  Both C<tempfile> and C<tempdir> may be exported on request and used as
  functions instead of as methods.
  
  The methods can be called on an instances representing a
  directory. In this case, the directory is used as the base to create the
  temporary file/directory, setting the C<DIR> option in File::Temp.
  
      my $target_dir = path('/to/destination');
      my $tempfile = $target_dir->tempfile('foobarXXXXXX');
      $tempfile->spew('A lot of data...');  # not atomic
      $tempfile->move($target_dir->child('foobar')); # hopefully atomic
  
  In this case, any value set for option C<DIR> is ignored.
  
  B<Note>: for tempfiles, the filehandles from File::Temp are closed and not
  reused.  This is not as secure as using File::Temp handles directly, but is
  less prone to deadlocks or access problems on some platforms.  Think of what
  C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
  up.
  
  B<Note 2>: if you don't want these cleaned up automatically when the object
  is destroyed, File::Temp requires different options for directories and
  files.  Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
  files.
  
  B<Note 3>: Don't lose the temporary object by chaining a method call instead
  of storing it:
  
      my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
  
  B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
  Keeping a reference to, or modifying the cached object may break the
  behavior documented above and is not supported.  Use at your own risk.
  
  Current API available since 0.119.
  
  =head1 METHODS
  
  =head2 absolute
  
      $abs = path("foo/bar")->absolute;
      $abs = path("foo/bar")->absolute("/tmp");
  
  Returns a new C<Path::Tiny> object with an absolute path (or itself if already
  absolute).  If no argument is given, the current directory is used as the
  absolute base path.  If an argument is given, it will be converted to an
  absolute path (if it is not already) and used as the absolute base path.
  
  This will not resolve upward directories ("foo/../bar") unless C<canonpath>
  in L<File::Spec> would normally do so on your platform.  If you need them
  resolved, you must call the more expensive C<realpath> method instead.
  
  On Windows, an absolute path without a volume component will have it added
  based on the current drive.
  
  Current API available since 0.101.
  
  =head2 append, append_raw, append_utf8
  
      path("foo.txt")->append(@data);
      path("foo.txt")->append(\@data);
      path("foo.txt")->append({binmode => ":raw"}, @data);
      path("foo.txt")->append_raw(@data);
      path("foo.txt")->append_utf8(@data);
  
  Appends data to a file.  The file is locked with C<flock> prior to writing
  and closed afterwards.  An optional hash reference may be used to pass
  options.  Valid options are:
  
  =over 4
  
  =item *
  
  C<binmode>: passed to C<binmode()> on the handle used for writing.
  
  =item *
  
  C<truncate>: truncates the file after locking and before appending
  
  =back
  
  The C<truncate> option is a way to replace the contents of a file
  B<in place>, unlike L</spew> which writes to a temporary file and then
  replaces the original (if it exists).
  
  C<append_raw> is like C<append> with a C<binmode> of C<:unix> for a fast,
  unbuffered, raw write.
  
  C<append_utf8> is like C<append> with an unbuffered C<binmode>
  C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
  L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, an
  unbuffered, raw append will be done instead on the data encoded with
  C<Unicode::UTF8>.
  
  Current API available since 0.060.
  
  =head2 assert
  
      $path = path("foo.txt")->assert( sub { $_->exists } );
  
  Returns the invocant after asserting that a code reference argument returns
  true.  When the assertion code reference runs, it will have the invocant
  object in the C<$_> variable.  If it returns false, an exception will be
  thrown.  The assertion code reference may also throw its own exception.
  
  If no assertion is provided, the invocant is returned without error.
  
  Current API available since 0.062.
  
  =head2 basename
  
      $name = path("foo/bar.txt")->basename;        # bar.txt
      $name = path("foo.txt")->basename('.txt');    # foo
      $name = path("foo.txt")->basename(qr/.txt/);  # foo
      $name = path("foo.txt")->basename(@suffixes);
  
  Returns the file portion or last directory portion of a path.
  
  Given a list of suffixes as strings or regular expressions, any that match at
  the end of the file portion or last directory portion will be removed before
  the result is returned.
  
  Current API available since 0.054.
  
  =head2 canonpath
  
      $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
  
  Returns a string with the canonical format of the path name for
  the platform.  In particular, this means directory separators
  will be C<\> on Windows.
  
  Current API available since 0.001.
  
  =head2 cached_temp
  
  Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
  C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
  If there is no such object, this method throws.
  
  B<WARNING>: Keeping a reference to, or modifying the cached object may
  break the behavior documented for temporary files and directories created
  with C<Path::Tiny> and is not supported.  Use at your own risk.
  
  Current API available since 0.101.
  
  =head2 child
  
      $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
      $file = path("/tmp")->child(@parts);
  
  Returns a new C<Path::Tiny> object relative to the original.  Works
  like C<catfile> or C<catdir> from File::Spec, but without caring about
  file or directories.
  
  B<WARNING>: because the argument could contain C<..> or refer to symlinks,
  there is no guarantee that the new path refers to an actual descendent of
  the original.  If this is important to you, transform parent and child with
  L</realpath> and check them with L</subsumes>.
  
  Current API available since 0.001.
  
  =head2 children
  
      @paths = path("/tmp")->children;
      @paths = path("/tmp")->children( qr/\.txt\z/ );
  
  Returns a list of C<Path::Tiny> objects for all files and directories
  within a directory.  Excludes "." and ".." automatically.
  
  If an optional C<qr//> argument is provided, it only returns objects for child
  names that match the given regular expression.  Only the base name is used
  for matching:
  
      @paths = path("/tmp")->children( qr/^foo/ );
      # matches children like the glob foo*
  
  Current API available since 0.028.
  
  =head2 chmod
  
      path("foo.txt")->chmod(0777);
      path("foo.txt")->chmod("0755");
      path("foo.txt")->chmod("go-w");
      path("foo.txt")->chmod("a=r,u+wx");
  
  Sets file or directory permissions.  The argument can be a numeric mode, a
  octal string beginning with a "0" or a limited subset of the symbolic mode use
  by F</bin/chmod>.
  
  The symbolic mode must be a comma-delimited list of mode clauses.  Clauses must
  match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
  "perms" parameters for each clause.  Unlike F</bin/chmod>, all three parameters
  are required for each clause, multiple ops are not allowed and permissions
  C<stugoX> are not supported.  (See L<File::chmod> for more complex needs.)
  
  Current API available since 0.053.
  
  =head2 copy
  
      path("/tmp/foo.txt")->copy("/tmp/bar.txt");
  
  Copies the current path to the given destination using L<File::Copy>'s
  C<copy> function. Upon success, returns the C<Path::Tiny> object for the
  newly copied file.
  
  Current API available since 0.070.
  
  =head2 digest
  
      $obj = path("/tmp/foo.txt")->digest;        # SHA-256
      $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
      $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );
  
  Returns a hexadecimal digest for a file.  An optional hash reference of options may
  be given.  The only option is C<chunk_size>.  If C<chunk_size> is given, that many
  bytes will be read at a time.  If not provided, the entire file will be slurped
  into memory to compute the digest.
  
  Any subsequent arguments are passed to the constructor for L<Digest> to select
  an algorithm.  If no arguments are given, the default is SHA-256.
  
  Current API available since 0.056.
  
  =head2 dirname (deprecated)
  
      $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
  
  Returns the directory portion you would get from calling
  C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
  parent directory portion.  Because L<File::Spec> is inconsistent, the result
  might or might not have a trailing slash.  Because of this, this method is
  B<deprecated>.
  
  A better, more consistently approach is likely C<< $path->parent->stringify >>,
  which will not have a trailing slash except for a root directory.
  
  Deprecated in 0.056.
  
  =head2 edit, edit_raw, edit_utf8
  
      path("foo.txt")->edit( \&callback, $options );
      path("foo.txt")->edit_utf8( \&callback );
      path("foo.txt")->edit_raw( \&callback );
  
  These are convenience methods that allow "editing" a file using a single
  callback argument. They slurp the file using C<slurp>, place the contents
  inside a localized C<$_> variable, call the callback function (without
  arguments), and then write C<$_> (presumably mutated) back to the
  file with C<spew>.
  
  An optional hash reference may be used to pass options.  The only option is
  C<binmode>, which is passed to C<slurp> and C<spew>.
  
  C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
  C<spew_*> methods.
  
  Current API available since 0.077.
  
  =head2 edit_lines, edit_lines_utf8, edit_lines_raw
  
      path("foo.txt")->edit_lines( \&callback, $options );
      path("foo.txt")->edit_lines_utf8( \&callback );
      path("foo.txt")->edit_lines_raw( \&callback );
  
  These are convenience methods that allow "editing" a file's lines using a
  single callback argument.  They iterate over the file: for each line, the
  line is put into a localized C<$_> variable, the callback function is
  executed (without arguments) and then C<$_> is written to a temporary file.
  When iteration is finished, the temporary file is atomically renamed over
  the original.
  
  An optional hash reference may be used to pass options.  The only option is
  C<binmode>, which is passed to the method that open handles for reading and
  writing.
  
  C<edit_lines_raw> is like C<edit_lines> with a buffered C<binmode> of
  C<:raw>.
  
  C<edit_lines_utf8> is like C<edit_lines> with a buffered C<binmode>
  C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
  L<PerlIO::utf8_strict>).
  
  Current API available since 0.077.
  
  =head2 exists, is_file, is_dir
  
      if ( path("/tmp")->exists ) { ... }     # -e
      if ( path("/tmp")->is_dir ) { ... }     # -d
      if ( path("/tmp")->is_file ) { ... }    # -e && ! -d
  
  Implements file test operations, this means the file or directory actually has
  to exist on the filesystem.  Until then, it's just a path.
  
  B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>.
  C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
  read just like files.
  
  Use C<-f> instead if you really mean to check for a plain file.
  
  Current API available since 0.053.
  
  =head2 filehandle
  
      $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
      $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
      $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1  }, $mode, $binmode);
  
  Returns an open file handle.  The C<$mode> argument must be a Perl-style
  read/write mode string ("<" ,">", ">>", etc.).  If a C<$binmode>
  is given, it is set during the C<open> call.
  
  An optional hash reference may be used to pass options.
  
  The C<locked> option governs file locking; if true, handles opened for writing,
  appending or read-write are locked with C<LOCK_EX>; otherwise, they are
  locked with C<LOCK_SH>.  When using C<locked>, ">" or "+>" modes will delay
  truncation until after the lock is acquired.
  
  The C<exclusive> option causes the open() call to fail if the file already
  exists.  This corresponds to the O_EXCL flag to sysopen / open(2).
  C<exclusive> implies C<locked> and will set it for you if you forget it.
  
  See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar.
  
  Current API available since 0.066.
  
  =head2 has_same_bytes
  
      if ( path("foo.txt")->has_same_bytes("bar.txt") ) {
         # ...
      }
  
  This method returns true if both the invocant and the argument can be opened as
  file handles and the handles contain the same bytes.  It returns false if their
  contents differ.  If either can't be opened as a file (e.g. a directory or
  non-existent file), the method throws an exception.  If both can be opened and
  both have the same C<realpath>, the method returns true without scanning any
  data.
  
  Current API available since 0.125.
  
  =head2 is_absolute, is_relative
  
      if ( path("/tmp")->is_absolute ) { ... }
      if ( path("/tmp")->is_relative ) { ... }
  
  Booleans for whether the path appears absolute or relative.
  
  Current API available since 0.001.
  
  =head2 is_rootdir
  
      while ( ! $path->is_rootdir ) {
          $path = $path->parent;
          ...
      }
  
  Boolean for whether the path is the root directory of the volume.  I.e. the
  C<dirname> is C<q[/]> and the C<basename> is C<q[]>.
  
  This works even on C<MSWin32> with drives and UNC volumes:
  
      path("C:/")->is_rootdir;             # true
      path("//server/share/")->is_rootdir; #true
  
  Current API available since 0.038.
  
  =head2 iterator
  
      $iter = path("/tmp")->iterator( \%options );
  
  Returns a code reference that walks a directory lazily.  Each invocation
  returns a C<Path::Tiny> object or undef when the iterator is exhausted.
  
      $iter = path("/tmp")->iterator;
      while ( $path = $iter->() ) {
          ...
      }
  
  The current and parent directory entries ("." and "..") will not
  be included.
  
  If the C<recurse> option is true, the iterator will walk the directory
  recursively, breadth-first.  If the C<follow_symlinks> option is also true,
  directory links will be followed recursively.  There is no protection against
  loops when following links. If a directory is not readable, it will not be
  followed.
  
  The default is the same as:
  
      $iter = path("/tmp")->iterator( {
          recurse         => 0,
          follow_symlinks => 0,
      } );
  
  For a more powerful, recursive iterator with built-in loop avoidance, see
  L<Path::Iterator::Rule>.
  
  See also L</visit>.
  
  Current API available since 0.016.
  
  =head2 lines, lines_raw, lines_utf8
  
      @contents = path("/tmp/foo.txt")->lines;
      @contents = path("/tmp/foo.txt")->lines(\%options);
      @contents = path("/tmp/foo.txt")->lines_raw;
      @contents = path("/tmp/foo.txt")->lines_utf8;
  
      @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
  
  Returns a list of lines from a file.  Optionally takes a hash-reference of
  options.  Valid options are C<binmode>, C<count> and C<chomp>.
  
  If C<binmode> is provided, it will be set on the handle prior to reading.
  
  If a positive C<count> is provided, that many lines will be returned from the
  start of the file.  If a negative C<count> is provided, the entire file will be
  read, but only C<abs(count)> will be kept and returned.  If C<abs(count)>
  exceeds the number of lines in the file, all lines will be returned.
  
  If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
  C<LF>) will be removed from the lines returned.
  
  Because the return is a list, C<lines> in scalar context will return the number
  of lines (and throw away the data).
  
      $number_of_lines = path("/tmp/foo.txt")->lines;
  
  C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>.  We use C<:raw>
  instead of C<:unix> so PerlIO buffering can manage reading by line.
  
  C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
  (or C<:raw:utf8_strict> with L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
  0.58+ is installed, a raw, unbuffered UTF-8 slurp will be done and then the
  lines will be split.  This is actually faster than relying on
  IO layers, though a bit memory intensive.  If memory use is a
  concern, consider C<openr_utf8> and iterating directly on the handle.
  
  See also L</slurp> if you want to load a file as a whole chunk.
  
  Current API available since 0.065.
  
  =head2 mkdir
  
      path("foo/bar/baz")->mkdir;
      path("foo/bar/baz")->mkdir( \%options );
  
  Like calling C<make_path> from L<File::Path>.  An optional hash reference
  is passed through to C<make_path>.  Errors will be trapped and an exception
  thrown.  Returns the the path object to facilitate chaining.
  
  B<NOTE>: unlike Perl's builtin C<mkdir>, this will create intermediate paths
  similar to the Unix C<mkdir -p> command.  It will not error if applied to an
  existing directory.
  
  Passing a defined argument I<other> than a hash reference is an error, and an
  exception will be thrown.
  
  Current API available since 0.125.
  
  =head2 mkpath (deprecated)
  
  Like calling C<mkdir>, but returns the list of directories created or an empty list if
  the directories already exist, just like C<make_path>.
  
  Passing a defined argument I<other> than a hash reference is an error, and an
  exception will be thrown.
  
  Deprecated in 0.125.
  
  =head2 move
  
      path("foo.txt")->move("bar.txt");
  
  Moves the current path to the given destination using L<File::Copy>'s
  C<move> function. Upon success, returns the C<Path::Tiny> object for the
  newly moved file.
  
  If the destination already exists and is a directory, and the source is not a
  directory, then the source file will be renamed into the directory
  specified by the destination.
  
  If possible, move() will simply rename the file. Otherwise, it
  copies the file to the new location and deletes the original. If an
  error occurs during this copy-and-delete process, you may be left
  with a (possibly partial) copy of the file under the destination
  name.
  
  Current API available since 0.124. Prior versions used Perl's
  -built-in (and less robust) L<rename|perlfunc/rename> function
  and did not return an object.
  
  =head2 openr, openw, openrw, opena
  
      $fh = path("foo.txt")->openr($binmode);  # read
      $fh = path("foo.txt")->openr_raw;
      $fh = path("foo.txt")->openr_utf8;
  
      $fh = path("foo.txt")->openw($binmode);  # write
      $fh = path("foo.txt")->openw_raw;
      $fh = path("foo.txt")->openw_utf8;
  
      $fh = path("foo.txt")->opena($binmode);  # append
      $fh = path("foo.txt")->opena_raw;
      $fh = path("foo.txt")->opena_utf8;
  
      $fh = path("foo.txt")->openrw($binmode); # read/write
      $fh = path("foo.txt")->openrw_raw;
      $fh = path("foo.txt")->openrw_utf8;
  
  Returns a file handle opened in the specified mode.  The C<openr> style methods
  take a single C<binmode> argument.  All of the C<open*> methods have
  C<open*_raw> and C<open*_utf8> equivalents that use buffered I/O layers C<:raw>
  and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
  L<PerlIO::utf8_strict>).
  
  An optional hash reference may be used to pass options.  The only option is
  C<locked>.  If true, handles opened for writing, appending or read-write are
  locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.
  
      $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
  
  See L</filehandle> for more on locking.
  
  Current API available since 0.011.
  
  =head2 parent
  
      $parent = path("foo/bar/baz")->parent; # foo/bar
      $parent = path("foo/wibble.txt")->parent; # foo
  
      $parent = path("foo/bar/baz")->parent(2); # foo
  
  Returns a C<Path::Tiny> object corresponding to the parent directory of the
  original directory or file. An optional positive integer argument is the number
  of parent directories upwards to return.  C<parent> by itself is equivalent to
  C<parent(1)>.
  
  Current API available since 0.014.
  
  =head2 realpath
  
      $real = path("/baz/foo/../bar")->realpath;
      $real = path("foo/../bar")->realpath;
  
  Returns a new C<Path::Tiny> object with all symbolic links and upward directory
  parts resolved using L<Cwd>'s C<realpath>.  Compared to C<absolute>, this is
  more expensive as it must actually consult the filesystem.
  
  If the parent path can't be resolved (e.g. if it includes directories that
  don't exist), an exception will be thrown:
  
      $real = path("doesnt_exist/foo")->realpath; # dies
  
  However, if the parent path exists and only the last component (e.g. filename)
  doesn't exist, the realpath will be the realpath of the parent plus the
  non-existent last component:
  
      $real = path("./aasdlfasdlf")->realpath; # works
  
  The underlying L<Cwd> module usually worked this way on Unix, but died on
  Windows (and some Unixes) if the full path didn't exist.  As of version 0.064,
  it's safe to use anywhere.
  
  Current API available since 0.001.
  
  =head2 relative
  
      $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
  
  Returns a C<Path::Tiny> object with a path relative to a new base path
  given as an argument.  If no argument is given, the current directory will
  be used as the new base path.
  
  If either path is already relative, it will be made absolute based on the
  current directly before determining the new relative path.
  
  The algorithm is roughly as follows:
  
  =over 4
  
  =item *
  
  If the original and new base path are on different volumes, an exception will be thrown.
  
  =item *
  
  If the original and new base are identical, the relative path is C<".">.
  
  =item *
  
  If the new base subsumes the original, the relative path is the original path with the new base chopped off the front
  
  =item *
  
  If the new base does not subsume the original, a common prefix path is determined (possibly the root directory) and the relative path will consist of updirs (C<"..">) to reach the common prefix, followed by the original path less the common prefix.
  
  =back
  
  Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
  on a common prefix takes into account symlinks that could affect the updir
  process.  Given an original path "/A/B" and a new base "/A/C",
  (where "A", "B" and "C" could each have multiple path components):
  
  =over 4
  
  =item *
  
  Symlinks in "A" don't change the result unless the last component of A is a symlink and the first component of "C" is an updir.
  
  =item *
  
  Symlinks in "B" don't change the result and will exist in the result as given.
  
  =item *
  
  Symlinks and updirs in "C" must be resolved to actual paths, taking into account the possibility that not all path components might exist on the filesystem.
  
  =back
  
  Current API available since 0.001.  New algorithm (that accounts for
  symlinks) available since 0.079.
  
  =head2 remove
  
      path("foo.txt")->remove;
  
  This is just like C<unlink>, except for its error handling: if the path does
  not exist, it returns false; if deleting the file fails, it throws an
  exception.
  
  Current API available since 0.012.
  
  =head2 remove_tree
  
      # directory
      path("foo/bar/baz")->remove_tree;
      path("foo/bar/baz")->remove_tree( \%options );
      path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
  
  Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
  An optional hash reference is passed through to C<remove_tree>.  Errors will be
  trapped and an exception thrown.  Returns the number of directories deleted,
  just like C<remove_tree>.
  
  If you want to remove a directory only if it is empty, use the built-in
  C<rmdir> function instead.
  
      rmdir path("foo/bar/baz/");
  
  Current API available since 0.013.
  
  Passing a defined argument I<other> than a hash reference is an error, and an
  exception will be thrown.
  
  =head2 sibling
  
      $foo = path("/tmp/foo.txt");
      $sib = $foo->sibling("bar.txt");        # /tmp/bar.txt
      $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
  
  Returns a new C<Path::Tiny> object relative to the parent of the original.
  This is slightly more efficient than C<< $path->parent->child(...) >>.
  
  Current API available since 0.058.
  
  =head2 size, size_human
  
      my $p = path("foo"); # with size 1025 bytes
  
      $p->size;                            # "1025"
      $p->size_human;                      # "1.1 K"
      $p->size_human( {format => "iec"} ); # "1.1 KiB"
  
  Returns the size of a file.  The C<size> method is just a wrapper around C<-s>.
  
  The C<size_human> method provides a human-readable string similar to
  C<ls -lh>.  Like C<ls>, it rounds upwards and provides one decimal place for
  single-digit sizes and no decimal places for larger sizes.  The only available
  option is C<format>, which has three valid values:
  
  =over 4
  
  =item *
  
  'ls' (the default): base-2 sizes, with C<ls> style single-letter suffixes (K, M, etc.)
  
  =item *
  
  'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.)
  
  =item *
  
  'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.)
  
  =back
  
  If C<-s> would return C<undef>, C<size_human> returns the empty string.
  
  Current API available since 0.122.
  
  =head2 slurp, slurp_raw, slurp_utf8
  
      $data = path("foo.txt")->slurp;
      $data = path("foo.txt")->slurp( {binmode => ":raw"} );
      $data = path("foo.txt")->slurp_raw;
      $data = path("foo.txt")->slurp_utf8;
  
  Reads file contents into a scalar.  Takes an optional hash reference which may
  be used to pass options.  The only available option is C<binmode>, which is
  passed to C<binmode()> on the handle used for reading.
  
  C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
  a fast, unbuffered, raw read.
  
  C<slurp_utf8> is like C<slurp> with a C<binmode> of
  C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
  L<PerlIO::utf8_strict>).  If L<Unicode::UTF8> 0.58+ is installed, a
  unbuffered, raw slurp will be done instead and the result decoded with
  C<Unicode::UTF8>. This is just as strict and is roughly an order of
  magnitude faster than using C<:encoding(UTF-8)>.
  
  B<Note>: C<slurp> and friends lock the filehandle before slurping.  If
  you plan to slurp from a file created with L<File::Temp>, be sure to
  close other handles or open without locking to avoid a deadlock:
  
      my $tempfile = File::Temp->new(EXLOCK => 0);
      my $guts = path($tempfile)->slurp;
  
  See also L</lines> if you want to slurp a file into a line array.
  
  Current API available since 0.004.
  
  =head2 spew, spew_raw, spew_utf8
  
      path("foo.txt")->spew(@data);
      path("foo.txt")->spew(\@data);
      path("foo.txt")->spew({binmode => ":raw"}, @data);
      path("foo.txt")->spew_raw(@data);
      path("foo.txt")->spew_utf8(@data);
  
  Writes data to a file atomically.  The file is written to a temporary file in
  the same directory, then renamed over the original.  An optional hash reference
  may be used to pass options.  The only option is C<binmode>, which is passed to
  C<binmode()> on the handle used for writing.
  
  C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
  unbuffered, raw write.
  
  C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
  (or C<:unix:utf8_strict> with L<PerlIO::utf8_strict>).  If L<Unicode::UTF8>
  0.58+ is installed, a raw, unbuffered spew will be done instead on the data
  encoded with C<Unicode::UTF8>.
  
  B<NOTE>: because the file is written to a temporary file and then renamed, the
  new file will wind up with permissions based on your current umask.  This is a
  feature to protect you from a race condition that would otherwise give
  different permissions than you might expect.  If you really want to keep the
  original mode flags, use L</append> with the C<truncate> option.
  
  Current API available since 0.011.
  
  =head2 stat, lstat
  
      $stat = path("foo.txt")->stat;
      $stat = path("/some/symlink")->lstat;
  
  Like calling C<stat> or C<lstat> from L<File::stat>.
  
  Current API available since 0.001.
  
  =head2 stringify
  
      $path = path("foo.txt");
      say $path->stringify; # same as "$path"
  
  Returns a string representation of the path.  Unlike C<canonpath>, this method
  returns the path standardized with Unix-style C</> directory separators.
  
  Current API available since 0.001.
  
  =head2 subsumes
  
      path("foo/bar")->subsumes("foo/bar/baz"); # true
      path("/foo/bar")->subsumes("/foo/baz");   # false
  
  Returns true if the first path is a prefix of the second path at a directory
  boundary.
  
  This B<does not> resolve parent directory entries (C<..>) or symlinks:
  
      path("foo/bar")->subsumes("foo/bar/../baz"); # true
  
  If such things are important to you, ensure that both paths are resolved to
  the filesystem with C<realpath>:
  
      my $p1 = path("foo/bar")->realpath;
      my $p2 = path("foo/bar/../baz")->realpath;
      if ( $p1->subsumes($p2) ) { ... }
  
  Current API available since 0.048.
  
  =head2 touch
  
      path("foo.txt")->touch;
      path("foo.txt")->touch($epoch_secs);
  
  Like the Unix C<touch> utility.  Creates the file if it doesn't exist, or else
  changes the modification and access times to the current time.  If the first
  argument is the epoch seconds then it will be used.
  
  Returns the path object so it can be easily chained with other methods:
  
      # won't die if foo.txt doesn't exist
      $content = path("foo.txt")->touch->slurp;
  
  Current API available since 0.015.
  
  =head2 touchpath
  
      path("bar/baz/foo.txt")->touchpath;
  
  Combines C<mkdir> and C<touch>.  Creates the parent directory if it doesn't exist,
  before touching the file.  Returns the path object like C<touch> does.
  
  If you need to pass options, use C<mkdir> and C<touch> separately:
  
      path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs);
  
  Current API available since 0.022.
  
  =head2 visit
  
      path("/tmp")->visit( \&callback, \%options );
  
  Executes a callback for each child of a directory.  It returns a hash
  reference with any state accumulated during iteration.
  
  The options are the same as for L</iterator> (which it uses internally):
  C<recurse> and C<follow_symlinks>.  Both default to false.
  
  The callback function will receive a C<Path::Tiny> object as the first argument
  and a hash reference to accumulate state as the second argument.  For example:
  
      # collect files sizes
      my $sizes = path("/tmp")->visit(
          sub {
              my ($path, $state) = @_;
              return if $path->is_dir;
              $state->{$path} = -s $path;
          },
          { recurse => 1 }
      );
  
  For convenience, the C<Path::Tiny> object will also be locally aliased as the
  C<$_> global variable:
  
      # print paths matching /foo/
      path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
  
  If the callback returns a B<reference> to a false scalar value, iteration will
  terminate.  This is not the same as "pruning" a directory search; this just
  stops all iteration and returns the state hash reference.
  
      # find up to 10 files larger than 100K
      my $files = path("/tmp")->visit(
          sub {
              my ($path, $state) = @_;
              $state->{$path}++ if -s $path > 102400
              return \0 if keys %$state == 10;
          },
          { recurse => 1 }
      );
  
  If you want more flexible iteration, use a module like L<Path::Iterator::Rule>.
  
  Current API available since 0.062.
  
  =head2 volume
  
      $vol = path("/tmp/foo.txt")->volume;   # ""
      $vol = path("C:/tmp/foo.txt")->volume; # "C:"
  
  Returns the volume portion of the path.  This is equivalent
  to what L<File::Spec> would give from C<splitpath> and thus
  usually is the empty string on Unix-like operating systems or the
  drive letter for an absolute path on C<MSWin32>.
  
  Current API available since 0.001.
  
  =for Pod::Coverage openr_utf8 opena_utf8 openw_utf8 openrw_utf8
  openr_raw opena_raw openw_raw openrw_raw
  IS_WIN32 FREEZE THAW TO_JSON abs2rel
  
  =head1 EXCEPTION HANDLING
  
  Simple usage errors will generally croak.  Failures of underlying Perl
  functions will be thrown as exceptions in the class
  C<Path::Tiny::Error>.
  
  A C<Path::Tiny::Error> object will be a hash reference with the following fields:
  
  =over 4
  
  =item *
  
  C<op> — a description of the operation, usually function call and any extra info
  
  =item *
  
  C<file> — the file or directory relating to the error
  
  =item *
  
  C<err> — hold C<$!> at the time the error was thrown
  
  =item *
  
  C<msg> — a string combining the above data and a Carp-like short stack trace
  
  =back
  
  Exception objects will stringify as the C<msg> field.
  
  =head1 ENVIRONMENT
  
  =head2 PERL_PATH_TINY_NO_FLOCK
  
  If the environment variable C<PERL_PATH_TINY_NO_FLOCK> is set to a true
  value then flock will NOT be used when accessing files (this is not
  recommended).
  
  =head1 CAVEATS
  
  =head2 Subclassing not supported
  
  For speed, this class is implemented as an array based object and uses many
  direct function calls internally.  You must not subclass it and expect
  things to work properly.
  
  =head2 Tilde expansion (deprecated)
  
  Tilde expansion was a nice idea, but it can't easily be applied consistently
  across the entire API.  This was a source of bugs and confusion for users.
  Therefore, it is B<deprecated> and its use is discouraged.  Limitations to the
  existing, legacy behavior follow.
  
  Tilde expansion will only occur if the B<first> argument to C<path> begins with
  a tilde. B<No other method does tilde expansion on its arguments>.  If you want
  tilde expansion on arguments, you must explicitly wrap them in a call to
  C<path>.
  
      path( "~/foo.txt" )->copy( path( "~/bar.txt" ) );
  
  If you need a literal leading tilde, use C<path("./~whatever")> so that the
  argument to C<path> doesn't start with a tilde, but the path still resolves to
  the current directory.
  
  Behaviour of tilde expansion with a username for non-existent users depends on
  the output of C<glob> on the system.
  
  =head2 File locking
  
  If flock is not supported on a platform, it will not be used, even if
  locking is requested.
  
  In situations where a platform normally would support locking, but the
  flock fails due to a filesystem limitation, Path::Tiny has some heuristics
  to detect this and will warn once and continue in an unsafe mode.  If you
  want this failure to be fatal, you can fatalize the 'flock' warnings
  category:
  
      use warnings FATAL => 'flock';
  
  See additional caveats below.
  
  =head3 NFS and BSD
  
  On BSD, Perl's flock implementation may not work to lock files on an
  NFS filesystem.  If detected, this situation will warn once, as described
  above.
  
  =head3 Lustre
  
  The Lustre filesystem does not support flock.  If detected, this situation
  will warn once, as described above.
  
  =head3 AIX and locking
  
  AIX requires a write handle for locking.  Therefore, calls that normally
  open a read handle and take a shared lock instead will open a read-write
  handle and take an exclusive lock.  If the user does not have write
  permission, no lock will be used.
  
  =head2 utf8 vs UTF-8
  
  All the C<*_utf8> methods by default use C<:encoding(UTF-8)> -- either as
  C<:unix:encoding(UTF-8)> (unbuffered, for whole file operations) or
  C<:raw:encoding(UTF-8)> (buffered, for line-by-line operations). These are
  strict against the Unicode spec and disallows illegal Unicode codepoints or
  UTF-8 sequences.
  
  Unfortunately, C<:encoding(UTF-8)> is very, very slow.  If you install
  L<Unicode::UTF8> 0.58 or later, that module will be used by some C<*_utf8>
  methods to encode or decode data after a raw, binary input/output operation,
  which is much faster.  Alternatively, if you install L<PerlIO::utf8_strict>,
  that will be used instead of C<:encoding(UTF-8)> and is also very fast.
  
  If you need the performance and can accept the security risk,
  C<< slurp({binmode => ":unix:utf8"}) >> will be faster than C<:unix:encoding(UTF-8)>
  (but not as fast as C<Unicode::UTF8>).
  
  Note that the C<*_utf8> methods read in B<raw> mode.  There is no CRLF
  translation on Windows.  If you must have CRLF translation, use the regular
  input/output methods with an appropriate binmode:
  
    $path->spew_utf8($data);                            # raw
    $path->spew({binmode => ":encoding(UTF-8)"}, $data; # LF -> CRLF
  
  =head2 Default IO layers and the open pragma
  
  If you have Perl 5.10 or later, file input/output methods (C<slurp>, C<spew>,
  etc.) and high-level handle opening methods ( C<filehandle>, C<openr>,
  C<openw>, etc. ) respect default encodings set by the C<-C> switch or lexical
  L<open> settings of the caller.  For UTF-8, this is almost certainly slower
  than using the dedicated C<_utf8> methods if you have L<Unicode::UTF8> or
  L<PerlIP::utf8_strict>.
  
  =head1 TYPE CONSTRAINTS AND COERCION
  
  A standard L<MooseX::Types> library is available at
  L<MooseX::Types::Path::Tiny>.  A L<Type::Tiny> equivalent is available as
  L<Types::Path::Tiny>.
  
  =head1 SEE ALSO
  
  These are other file/path utilities, which may offer a different feature
  set than C<Path::Tiny>.
  
  =over 4
  
  =item *
  
  L<File::chmod>
  
  =item *
  
  L<File::Fu>
  
  =item *
  
  L<IO::All>
  
  =item *
  
  L<Path::Class>
  
  =back
  
  These iterators may be slightly faster than the recursive iterator in
  C<Path::Tiny>:
  
  =over 4
  
  =item *
  
  L<Path::Iterator::Rule>
  
  =item *
  
  L<File::Next>
  
  =back
  
  There are probably comparable, non-Tiny tools.  Let me know if you want me to
  add a module to the list.
  
  This module was featured in the L<2013 Perl Advent Calendar|http://www.perladvent.org/2013/2013-12-18.html>.
  
  =for :stopwords cpan testmatrix url 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/Path-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/Path-Tiny>
  
    git clone https://github.com/dagolden/Path-Tiny.git
  
  =head1 AUTHOR
  
  David Golden <dagolden@cpan.org>
  
  =head1 CONTRIBUTORS
  
  =for stopwords Alex Efros Aristotle Pagaltzis Chris Williams Dan Book Dave Rolsky David Steinbrunner Doug Bell Elvin Aslanov Flavio Poletti Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis Ian Sillitoe James Hunt John Karr Karen Etheridge Mark Ellis Martin H. Sluka Kjeldsen Mary Ehlers Michael G. Schwern NATARAJ (Nikolay Shaplov) Nicolas R Rochelemagne Nigel Gregoire Philippe Bruhat (BooK) regina-verbae Ricardo Signes Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux yoshikazusawa 김도형 - Keedi Kim
  
  =over 4
  
  =item *
  
  Alex Efros <powerman@powerman.name>
  
  =item *
  
  Aristotle Pagaltzis <pagaltzis@gmx.de>
  
  =item *
  
  Chris Williams <bingos@cpan.org>
  
  =item *
  
  Dan Book <grinnz@grinnz.com>
  
  =item *
  
  Dave Rolsky <autarch@urth.org>
  
  =item *
  
  David Steinbrunner <dsteinbrunner@pobox.com>
  
  =item *
  
  Doug Bell <madcityzen@gmail.com>
  
  =item *
  
  Elvin Aslanov <rwp.primary@gmail.com>
  
  =item *
  
  Flavio Poletti <flavio@polettix.it>
  
  =item *
  
  Gabor Szabo <szabgab@cpan.org>
  
  =item *
  
  Gabriel Andrade <gabiruh@gmail.com>
  
  =item *
  
  George Hartzell <hartzell@cpan.org>
  
  =item *
  
  Geraud Continsouzas <geraud@scsi.nc>
  
  =item *
  
  Goro Fuji <gfuji@cpan.org>
  
  =item *
  
  Graham Knop <haarg@haarg.org>
  
  =item *
  
  Graham Ollis <plicease@cpan.org>
  
  =item *
  
  Ian Sillitoe <ian@sillit.com>
  
  =item *
  
  James Hunt <james@niftylogic.com>
  
  =item *
  
  John Karr <brainbuz@brainbuz.org>
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Mark Ellis <mark.ellis@cartridgesave.co.uk>
  
  =item *
  
  Martin H. Sluka <fany@cpan.org>
  
  =item *
  
  Martin Kjeldsen <mk@bluepipe.dk>
  
  =item *
  
  Martin Sluka <martin@sluka.de>
  
  =item *
  
  Mary Ehlers <regina.verb.ae@gmail.com>
  
  =item *
  
  Michael G. Schwern <mschwern@cpan.org>
  
  =item *
  
  NATARAJ (Nikolay Shaplov) <dhyan@nataraj.su>
  
  =item *
  
  Nicolas R <nicolas@atoomic.org>
  
  =item *
  
  Nicolas Rochelemagne <rochelemagne@cpanel.net>
  
  =item *
  
  Nigel Gregoire <nigelgregoire@gmail.com>
  
  =item *
  
  Philippe Bruhat (BooK) <book@cpan.org>
  
  =item *
  
  regina-verbae <regina-verbae@users.noreply.github.com>
  
  =item *
  
  Ricardo Signes <rjbs@semiotic.systems>
  
  =item *
  
  Roy Ivy III <rivy@cpan.org>
  
  =item *
  
  Shlomi Fish <shlomif@shlomifish.org>
  
  =item *
  
  Smylers <Smylers@stripey.com>
  
  =item *
  
  Tatsuhiko Miyagawa <miyagawa@bulknews.net>
  
  =item *
  
  Toby Inkster <tobyink@cpan.org>
  
  =item *
  
  Yanick Champoux <yanick@babyl.dyndns.org>
  
  =item *
  
  yoshikazusawa <883514+yoshikazusawa@users.noreply.github.com>
  
  =item *
  
  김도형 - Keedi Kim <keedi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2014 by David Golden.
  
  This is free software, licensed under:
  
    The Apache License, Version 2.0, January 2004
  
  =cut
PATH_TINY

$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{"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.004';
  
  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
  
  =encoding UTF-8
  
  =head1 NAME
  
  Tie::Handle::Offset - Tied handle that hides the beginning of a file
  
  =head1 VERSION
  
  version 0.004
  
  =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<https://github.com/dagolden/tie-handle-offset/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/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.004';
  
  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
  
  =encoding UTF-8
  
  =head1 NAME
  
  Tie::Handle::SkipHeader - Tied handle that hides an RFC822-style header
  
  =head1 VERSION
  
  version 0.004
  
  =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{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TINY';
  package Try::Tiny; # git description: v0.31-2-gc8e3a47
  use 5.006;
  # ABSTRACT: Minimal try/catch with proper preservation of $@
  
  our $VERSION = '0.32';
  
  use strict;
  use warnings;
  
  use Exporter 5.57 'import';
  our @EXPORT = our @EXPORT_OK = qw(try catch finally);
  
  use Carp;
  $Carp::Internal{+__PACKAGE__}++;
  
  BEGIN {
    my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname;
    my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) };
    unless ($su || $sn) {
      $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname;
      unless ($su) {
        $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) };
      }
    }
  
    *_subname = $su ? \&Sub::Util::set_subname
              : $sn ? \&Sub::Name::subname
              : sub { $_[1] };
    *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0};
  }
  
  my %_finally_guards;
  
  # Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
  # Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
  # context & not a scalar one
  
  sub try (&;@) {
    my ( $try, @code_refs ) = @_;
  
    # we need to save this here, the eval block will be in scalar context due
    # to $failed
    my $wantarray = wantarray;
  
    # work around perl bug by explicitly initializing these, due to the likelyhood
    # this will be used in global destruction (perl rt#119311)
    my ( $catch, @finally ) = ();
  
    # find labeled blocks in the argument list.
    # catch and finally tag the blocks by blessing a scalar reference to them.
    foreach my $code_ref (@code_refs) {
  
      if ( ref($code_ref) eq 'Try::Tiny::Catch' ) {
        croak 'A try() may not be followed by multiple catch() blocks'
          if $catch;
        $catch = ${$code_ref};
      } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) {
        push @finally, ${$code_ref};
      } else {
        croak(
          'try() encountered an unexpected argument ('
        . ( defined $code_ref ? $code_ref : 'undef' )
        . ') - perhaps a missing semi-colon before or'
        );
      }
    }
  
    # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
    # not perfect, but we could provide a list of additional errors for
    # $catch->();
  
    # name the blocks if we have Sub::Name installed
    _subname(caller().'::try {...} ' => $try)
      if _HAS_SUBNAME;
  
    # set up scope guards to invoke the finally blocks at the end.
    # this should really be a function scope lexical variable instead of
    # file scope + local but that causes issues with perls < 5.20 due to
    # perl rt#119311
    local $_finally_guards{guards} = [
      map Try::Tiny::ScopeGuard->_new($_),
      @finally
    ];
  
    # save the value of $@ so we can set $@ back to it in the beginning of the eval
    # and restore $@ after the eval finishes
    my $prev_error = $@;
  
    my ( @ret, $error );
  
    # failed will be true if the eval dies, because 1 will not be returned
    # from the eval body
    my $failed = not eval {
      $@ = $prev_error;
  
      # evaluate the try block in the correct context
      if ( $wantarray ) {
        @ret = $try->();
      } elsif ( defined $wantarray ) {
        $ret[0] = $try->();
      } else {
        $try->();
      };
  
      return 1; # properly set $failed to false
    };
  
    # preserve the current error and reset the original value of $@
    $error = $@;
    $@ = $prev_error;
  
    # at this point $failed contains a true value if the eval died, even if some
    # destructor overwrote $@ as the eval was unwinding.
    if ( $failed ) {
      # pass $error to the finally blocks
      push @$_, $error for @{$_finally_guards{guards}};
  
      # if we got an error, invoke the catch block.
      if ( $catch ) {
        # This works like given($error), but is backwards compatible and
        # sets $_ in the dynamic scope for the body of C<$catch>
        for ($error) {
          return $catch->($error);
        }
  
        # in case when() was used without an explicit return, the C<for>
        # loop will be aborted and there's no useful return value
      }
  
      return;
    } else {
      # no failure, $@ is back to what it was, everything is fine
      return $wantarray ? @ret : $ret[0];
    }
  }
  
  sub catch (&;@) {
    my ( $block, @rest ) = @_;
  
    croak 'Useless bare catch()' unless wantarray;
  
    _subname(caller().'::catch {...} ' => $block)
      if _HAS_SUBNAME;
    return (
      bless(\$block, 'Try::Tiny::Catch'),
      @rest,
    );
  }
  
  sub finally (&;@) {
    my ( $block, @rest ) = @_;
  
    croak 'Useless bare finally()' unless wantarray;
  
    _subname(caller().'::finally {...} ' => $block)
      if _HAS_SUBNAME;
    return (
      bless(\$block, 'Try::Tiny::Finally'),
      @rest,
    );
  }
  
  {
    package # hide from PAUSE
      Try::Tiny::ScopeGuard;
  
    use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;
  
    sub _new {
      shift;
      bless [ @_ ];
    }
  
    sub DESTROY {
      my ($code, @args) = @{ $_[0] };
  
      local $@ if UNSTABLE_DOLLARAT;
      eval {
        $code->(@args);
        1;
      } or do {
        warn
          "Execution of finally() block $code resulted in an exception, which "
        . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
        . 'Your program will continue as if this event never took place. '
        . "Original exception text follows:\n\n"
        . (defined $@ ? $@ : '$@ left undefined...')
        . "\n"
        ;
      }
    }
  }
  
  __PACKAGE__
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  Try::Tiny - Minimal try/catch with proper preservation of $@
  
  =head1 VERSION
  
  version 0.32
  
  =head1 SYNOPSIS
  
  You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional
  conditions, avoiding quirks in Perl and common mistakes:
  
    # handle errors with a catch handler
    try {
      die "foo";
    } catch {
      warn "caught error: $_"; # not $@
    };
  
  You can also use it like a standalone C<eval> to catch and ignore any error
  conditions.  Obviously, this is an extreme measure not to be undertaken
  lightly:
  
    # just silence errors
    try {
      die "foo";
    };
  
  =head1 DESCRIPTION
  
  This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to
  minimize common mistakes with eval blocks, and NOTHING else.
  
  This is unlike L<TryCatch> which provides a nice syntax and avoids adding
  another call stack layer, and supports calling C<return> from the C<try> block to
  return from the parent subroutine. These extra features come at a cost of a few
  dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are
  occasionally problematic, and the additional catch filtering uses L<Moose>
  type constraints which may not be desirable either.
  
  The main focus of this module is to provide simple and reliable error handling
  for those having a hard time installing L<TryCatch>, but who still want to
  write correct C<eval> blocks without 5 lines of boilerplate each time.
  
  It's designed to work as correctly as possible in light of the various
  pathological edge cases (see L</BACKGROUND>) and to be compatible with any style
  of error values (simple strings, references, objects, overloaded objects, etc).
  
  If the C<try> block dies, it returns the value of the last statement executed in
  the C<catch> block, if there is one. Otherwise, it returns C<undef> in scalar
  context or the empty list in list context. The following examples all
  assign C<"bar"> to C<$x>:
  
    my $x = try { die "foo" } catch { "bar" };
    my $x = try { die "foo" } || "bar";
    my $x = (try { die "foo" }) // "bar";
  
    my $x = eval { die "foo" } || "bar";
  
  You can add C<finally> blocks, yielding the following:
  
    my $x;
    try { die 'foo' } finally { $x = 'bar' };
    try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
  
  C<finally> blocks are always executed making them suitable for cleanup code
  which cannot be handled using local.  You can add as many C<finally> blocks to a
  given C<try> block as you like.
  
  Note that adding a C<finally> block without a preceding C<catch> block
  suppresses any errors. This behaviour is consistent with using a standalone
  C<eval>, but it is not consistent with C<try>/C<finally> patterns found in
  other programming languages, such as Java, Python, Javascript or C#. If you
  learned the C<try>/C<finally> pattern from one of these languages, watch out for
  this.
  
  =head1 EXPORTS
  
  All functions are exported by default using L<Exporter>.
  
  If you need to rename the C<try>, C<catch> or C<finally> keyword consider using
  L<Sub::Import> to get L<Sub::Exporter>'s flexibility.
  
  =over 4
  
  =item try (&;@)
  
  Takes one mandatory C<try> subroutine, an optional C<catch> subroutine and C<finally>
  subroutine.
  
  The mandatory subroutine is evaluated in the context of an C<eval> block.
  
  If no error occurred the value from the first block is returned, preserving
  list/scalar context.
  
  If there was an error and the second subroutine was given it will be invoked
  with the error in C<$_> (localized) and as that block's first and only
  argument.
  
  C<$@> does B<not> contain the error. Inside the C<catch> block it has the same
  value it had before the C<try> block was executed.
  
  Note that the error may be false, but if that happens the C<catch> block will
  still be invoked.
  
  Once all execution is finished then the C<finally> block, if given, will execute.
  
  =item catch (&;@)
  
  Intended to be used in the second argument position of C<try>.
  
  Returns a reference to the subroutine it was given but blessed as
  C<Try::Tiny::Catch> which allows try to decode correctly what to do
  with this code reference.
  
    catch { ... }
  
  Inside the C<catch> block the caught error is stored in C<$_>, while previous
  value of C<$@> is still available for use.  This value may or may not be
  meaningful depending on what happened before the C<try>, but it might be a good
  idea to preserve it in an error stack.
  
  For code that captures C<$@> when throwing new errors (i.e.
  L<Class::Throwable>), you'll need to do:
  
    local $@ = $_;
  
  =item finally (&;@)
  
    try     { ... }
    catch   { ... }
    finally { ... };
  
  Or
  
    try     { ... }
    finally { ... };
  
  Or even
  
    try     { ... }
    finally { ... }
    catch   { ... };
  
  Intended to be the second or third element of C<try>. C<finally> blocks are always
  executed in the event of a successful C<try> or if C<catch> is run. This allows
  you to locate cleanup code which cannot be done via C<local()> e.g. closing a file
  handle.
  
  When invoked, the C<finally> block is passed the error that was caught.  If no
  error was caught, it is passed nothing.  (Note that the C<finally> block does not
  localize C<$_> with the error, since unlike in a C<catch> block, there is no way
  to know if C<$_ == undef> implies that there were no errors.) In other words,
  the following code does just what you would expect:
  
    try {
      die_sometimes();
    } catch {
      # ...code run in case of error
    } finally {
      if (@_) {
        print "The try block died with: @_\n";
      } else {
        print "The try block ran without error.\n";
      }
    };
  
  B<You must always do your own error handling in the C<finally> block>. C<Try::Tiny> will
  not do anything about handling possible errors coming from code located in these
  blocks.
  
  Furthermore B<exceptions in C<finally> blocks are not trappable and are unable
  to influence the execution of your program>. This is due to limitation of
  C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This
  may change in a future version of Try::Tiny.
  
  In the same way C<catch()> blesses the code reference this subroutine does the same
  except it bless them as C<Try::Tiny::Finally>.
  
  =back
  
  =head1 BACKGROUND
  
  There are a number of issues with C<eval>.
  
  =head2 Clobbering $@
  
  When you run an C<eval> block and it succeeds, C<$@> will be cleared, potentially
  clobbering an error that is currently being caught.
  
  This causes action at a distance, clearing previous errors your caller may have
  not yet handled.
  
  C<$@> must be properly localized before invoking C<eval> in order to avoid this
  issue.
  
  More specifically,
  L<before Perl version 5.14.0|perl5140delta/"Exception Handling">
  C<$@> was clobbered at the beginning of the C<eval>, which
  also made it impossible to capture the previous error before you die (for
  instance when making exception objects with error stacks).
  
  For this reason C<try> will actually set C<$@> to its previous value (the one
  available before entering the C<try> block) in the beginning of the C<eval>
  block.
  
  =head2 Localizing $@ silently masks errors
  
  Inside an C<eval> block, C<die> behaves sort of like:
  
    sub die {
      $@ = $_[0];
      return_undef_from_eval();
    }
  
  This means that if you were polite and localized C<$@> you can't die in that
  scope, or your error will be discarded (printing "Something's wrong" instead).
  
  The workaround is very ugly:
  
    my $error = do {
      local $@;
      eval { ... };
      $@;
    };
  
    ...
    die $error;
  
  =head2 $@ might not be a true value
  
  This code is wrong:
  
    if ( $@ ) {
      ...
    }
  
  because due to the previous caveats it may have been unset.
  
  C<$@> could also be an overloaded error object that evaluates to false, but
  that's asking for trouble anyway.
  
  The classic failure mode (fixed in L<Perl 5.14.0|perl5140delta/"Exception Handling">) is:
  
    sub Object::DESTROY {
      eval { ... }
    }
  
    eval {
      my $obj = Object->new;
  
      die "foo";
    };
  
    if ( $@ ) {
  
    }
  
  In this case since C<Object::DESTROY> is not localizing C<$@> but still uses
  C<eval>, it will set C<$@> to C<"">.
  
  The destructor is called when the stack is unwound, after C<die> sets C<$@> to
  C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has
  been cleared by C<eval> in the destructor.
  
  The workaround for this is even uglier than the previous ones. Even though we
  can't save the value of C<$@> from code that doesn't localize, we can at least
  be sure the C<eval> was aborted due to an error:
  
    my $failed = not eval {
      ...
  
      return 1;
    };
  
  This is because an C<eval> that caught a C<die> will always return a false
  value.
  
  =head1 ALTERNATE SYNTAX
  
  Using Perl 5.10 you can use L<perlsyn/"Switch statements"> (but please don't,
  because that syntax has since been deprecated because there was too much
  unexpected magical behaviour).
  
  =for stopwords topicalizer
  
  The C<catch> block is invoked in a topicalizer context (like a C<given> block),
  but note that you can't return a useful value from C<catch> using the C<when>
  blocks without an explicit C<return>.
  
  This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to
  concisely match errors:
  
    try {
      require Foo;
    } catch {
      when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
      default { die $_ }
    };
  
  =head1 CAVEATS
  
  =over 4
  
  =item *
  
  C<@_> is not available within the C<try> block, so you need to copy your
  argument list. In case you want to work with argument values directly via C<@_>
  aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference:
  
    sub foo {
      my ( $self, @args ) = @_;
      try { $self->bar(@args) }
    }
  
  or
  
    sub bar_in_place {
      my $self = shift;
      my $args = \@_;
      try { $_ = $self->bar($_) for @$args }
    }
  
  =item *
  
  C<return> returns from the C<try> block, not from the parent sub (note that
  this is also how C<eval> works, but not how L<TryCatch> works):
  
    sub parent_sub {
      try {
        die;
      }
      catch {
        return;
      };
  
      say "this text WILL be displayed, even though an exception is thrown";
    }
  
  Instead, you should capture the return value:
  
    sub parent_sub {
      my $success = try {
        die;
        1;
      };
      return unless $success;
  
      say "This text WILL NEVER appear!";
    }
    # OR
    sub parent_sub_with_catch {
      my $success = try {
        die;
        1;
      }
      catch {
        # do something with $_
        return undef; #see note
      };
      return unless $success;
  
      say "This text WILL NEVER appear!";
    }
  
  Note that if you have a C<catch> block, it must return C<undef> for this to work,
  since if a C<catch> block exists, its return value is returned in place of C<undef>
  when an exception is thrown.
  
  =item *
  
  C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp>
  will not report this when using full stack traces, though, because
  C<%Carp::Internal> is used. This lack of magic is considered a feature.
  
  =for stopwords unhygienically
  
  =item *
  
  The value of C<$_> in the C<catch> block is not guaranteed to be the value of
  the exception thrown (C<$@>) in the C<try> block.  There is no safe way to
  ensure this, since C<eval> may be used unhygienically in destructors.  The only
  guarantee is that the C<catch> will be called if an exception is thrown.
  
  =item *
  
  The return value of the C<catch> block is not ignored, so if testing the result
  of the expression for truth on success, be sure to return a false value from
  the C<catch> block:
  
    my $obj = try {
      MightFail->new;
    } catch {
      ...
  
      return; # avoid returning a true value;
    };
  
    return unless $obj;
  
  =item *
  
  C<$SIG{__DIE__}> is still in effect.
  
  Though it can be argued that C<$SIG{__DIE__}> should be disabled inside of
  C<eval> blocks, since it isn't people have grown to rely on it. Therefore in
  the interests of compatibility, C<try> does not disable C<$SIG{__DIE__}> for
  the scope of the error throwing code.
  
  =item *
  
  Lexical C<$_> may override the one set by C<catch>.
  
  For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some
  confusing behavior:
  
    given ($foo) {
      when (...) {
        try {
          ...
        } catch {
          warn $_; # will print $foo, not the error
          warn $_[0]; # instead, get the error like this
        }
      }
    }
  
  Note that this behavior was changed once again in
  L<Perl5 version 18|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
  However, since the entirety of lexical C<$_> is now L<considered experimental
  |https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it
  is unclear whether the new version 18 behavior is final.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<Syntax::Keyword::Try>
  
  Only available on perls >= 5.14, with a slightly different syntax (e.g. no trailing C<;> because
  it's actually a keyword, not a sub, but this means you can C<return> and C<next> within it). Use
  L<Feature::Compat::Try> to automatically switch to the native C<try> syntax in newer perls (when
  available). See also L<Try Catch Exception Handling|perlsyn/Try-Catch-Exception-Handling>.
  
  =item L<TryCatch>
  
  Much more feature complete, more convenient semantics, but at the cost of
  implementation complexity.
  
  =item L<autodie>
  
  Automatic error throwing for builtin functions and more. Also designed to
  work well with C<given>/C<when>.
  
  =item L<Throwable>
  
  A lightweight role for rolling your own exception classes.
  
  =item L<Error>
  
  Exception object implementation with a C<try> statement. Does not localize
  C<$@>.
  
  =item L<Exception::Class::TryCatch>
  
  Provides a C<catch> statement, but properly calling C<eval> is your
  responsibility.
  
  The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the
  issues with C<$@>, but you still need to localize to prevent clobbering.
  
  =back
  
  =head1 LIGHTNING TALK
  
  I gave a lightning talk about this module, you can see the slides (Firefox
  only):
  
  L<http://web.archive.org/web/20100628040134/http://nothingmuch.woobling.org/talks/takahashi.xul>
  
  Or read the source:
  
  L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
  
  =head1 SUPPORT
  
  Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny>
  (or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>).
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
  
  =item *
  
  Jesse Luehrs <doy@tozt.net>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Aristotle Pagaltzis Dagfinn Ilmari Mannsåker Lukas Mai Alex anaxagoras Andrew Yates awalker chromatic cm-perl David Lowe Glenn Hans Dieter Pearcey Jens Berthold Jonathan Yu Marc Mims Stosberg Pali Paul Howarth Rudolf Leermakers
  
  =over 4
  
  =item *
  
  Karen Etheridge <ether@cpan.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =item *
  
  Mark Fowler <mark@twoshortplanks.com>
  
  =item *
  
  Graham Knop <haarg@haarg.org>
  
  =item *
  
  Aristotle Pagaltzis <pagaltzis@gmx.de>
  
  =item *
  
  Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
  
  =item *
  
  Lukas Mai <l.mai@web.de>
  
  =item *
  
  Alex <alex@koban.(none)>
  
  =item *
  
  anaxagoras <walkeraj@gmail.com>
  
  =item *
  
  Andrew Yates <ayates@haddock.local>
  
  =item *
  
  awalker <awalker@sourcefire.com>
  
  =item *
  
  chromatic <chromatic@wgz.org>
  
  =item *
  
  cm-perl <cm-perl@users.noreply.github.com>
  
  =item *
  
  David Lowe <davidl@lokku.com>
  
  =item *
  
  Glenn Fowler <cebjyre@cpan.org>
  
  =item *
  
  Hans Dieter Pearcey <hdp@weftsoar.net>
  
  =item *
  
  Jens Berthold <jens@jebecs.de>
  
  =item *
  
  Jonathan Yu <JAWNSY@cpan.org>
  
  =item *
  
  Marc Mims <marc@questright.com>
  
  =item *
  
  Mark Stosberg <mark@stosberg.com>
  
  =item *
  
  Pali <pali@cpan.org>
  
  =item *
  
  Paul Howarth <paul@city-fan.org>
  
  =item *
  
  Rudolf Leermakers <rudolf@hatsuseno.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENCE
  
  This software is Copyright (c) 2009 by יובל קוג'מן (Yuval Kogman).
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
TRY_TINY

$fatpacked{"URI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI';
  package URI;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  # 1=version 5.10 and earlier; 0=version 5.11 and later
  use constant HAS_RESERVED_SQUARE_BRACKETS => $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} ? 1 : 0;
  
  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   = HAS_RESERVED_SQUARE_BRACKETS ? q(;/?:@&=+$,[]) : q(;/?:@&=+$,);
  our $mark       = q(-_.!~*'());                                    #'; emacs
  our $unreserved = "A-Za-z0-9\Q$mark\E";
  our $uric       = quotemeta($reserved) . $unreserved . "%";
  our $uric4host  = $uric . ( HAS_RESERVED_SQUARE_BRACKETS ? '' : quotemeta( q([]) ) );
  our $uric4user  = quotemeta( q{!$'()*,;:._~%-+=%&} ) . "A-Za-z0-9" . ( HAS_RESERVED_SQUARE_BRACKETS ? quotemeta( q([]) ) : '' ); # RFC-3987: iuserinfo w/o UTF
  
  our $scheme_re  = '[a-zA-Z][a-zA-Z0-9.+\-]*';
  
  # These schemes don't have an IPv6+ address part.
  our $schemes_without_host_part_re = 'data|ldapi|urn|sqlite|sqlite3';
  
  # These schemes can have an IPv6+ authority part:
  #     file, ftp, gopher, http, https, ldap, ldaps, mms, news, nntp, nntps, pop, rlogin, rtsp, rtspu, rsync, sip, sips, snews,
  #     telnet, tn3270, ssh, sftp
  #     (all DB URIs, i.e. cassandra, couch, couchdb, etc.), except 'sqlite:', 'sqlite3:'. Others?
  #MAINT: URI has no test coverage for DB schemes
  #MAINT: decoupling - perhaps let each class decide itself by defining a member function 'scheme_has_authority_part()'?
  
  #MAINT: 'mailto:' needs special treatment for IPv* addresses / RFC 5321 (4.1.3). Until then: restore all '[', ']'
  # These schemes need fallback to previous (<= 5.10) encoding until a specific handler is available.
  our $fallback_schemes_re = 'mailto';
  
  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;
  }
  
  
  #-- Version: 5.11+
  #   Since the complete URI will be percent-encoded including '[' and ']',
  #   we selectively unescape square brackets from the authority/host part of the URI.
  #   Derived modules that implement _uric_escape() should take this into account
  #   if they do not rely on URI::_uric_escape().
  #   No unescaping is performed for the userinfo@ part of the authority part.
  sub _fix_uric_escape_for_host_part {
    return if HAS_RESERVED_SQUARE_BRACKETS;
    return if $_[0] !~ /%/;
    return if $_[0] =~ m{^(?:$URI::schemes_without_host_part_re):}os;
  
    # until a scheme specific handler is available, fall back to previous behavior of v5.10 (i.e. 'mailto:')
    if ($_[0] =~ m{^(?:$URI::fallback_schemes_re):}os) {
      $_[0]    =~ s/\%5B/[/gi;
      $_[0]    =~ s/\%5D/]/gi;
      return;
    }
  
    if ($_[0] =~ m{^((?:$URI::scheme_re:)?)//([^/?\#]+)(.*)$}os) {
      my $orig          = $2;
      my ($user, $host) = $orig =~ /^(.*@)?([^@]*)$/;
      $user  ||= '';
      my $port = $host =~ s/(:\d+)$// ? $1 : '';
      #MAINT: die() here if scheme indicates TCP/UDP and port is out of range [0..65535] ?
      $host    =~ s/\%5B/[/gi;
      $host    =~ s/\%5D/]/gi;
      $_[0]    =~ s/\Q$orig\E/$user$host$port/;
    }
  }
  
  
  sub _uric_escape
  {
      my($class, $str) = @_;
      $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
      _fix_uric_escape_for_host_part( $str );
      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}) {
              $require_attempted{$ic} = 1;
  
              # 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.example.com");
   $u2 = URI->new("foo", "http");
   $u3 = $u2->abs($u1);
   $u4 = $u3->clone;
   $u5 = URI->new("HTTP://WWW.example.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.example.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.
  
  =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.
  
  =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 C<$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.
  
    my $uri = URI->new("http://www.\xC3\xBCri-sample/foo/bar.html");
    print $u->host; # www.xn--ri-sample-fra0f
  
  
  =item $uri->ihost
  
  Returns the host in Unicode form. Any IDNA A-labels (encoded unicode chars with
  I<xn--> prefix) are turned into U-labels (unicode chars).
  
    my $uri = URI->new("http://www.\xC3\xBCri-sample/foo/bar.html");
    print $u->ihost; # www.\xC3\xBCri-sample
  
  =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.
  
  It also supports accessing to the encryption mode ($uri->encrypt_mode),
  which has its own defaults for I<ftps> and I<ftpes> URI schemes.
  
  =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<geo>:
  
  The I<geo> URI scheme is specified in L<RFC 5870|http://tools.ietf.org/html/rfc5870>.
  The scheme is used to reference physical location in a two- or
  three-dimensional coordinate reference system in a compact, simple,
  human-readable, and protocol-independent way.
  
  C<URI> objects belonging to the geo scheme support the common methods.
  
  =item B<icap>:
  
  The I<icap> URI scheme is specified in L<RFC 3507|http://tools.ietf.org/html/rfc3507>.
  The scheme is used to reference resources hosted by ICAP servers.
  
  C<URI> objects belonging to the icap scheme support the common,
  generic and server methods.
  
  =item B<icaps>:
  
  The I<icaps> URI scheme is specified in L<RFC 3507|http://tools.ietf.org/html/rfc3507> as well.
  The scheme is used to reference ICAP servers through SSL
  connections.  Its syntax is the same as icap, including the same
  default port.
  
  =item B<irc>:
  
  The I<irc> URI scheme is specified in L<draft-butcher-irc-url-04|https://datatracker.ietf.org/doc/html/draft-butcher-irc-url-04>.
  The scheme is used to reference IRC servers and their resources.
  
  C<URI> objects belonging to the irc or ircs scheme support login
  methods, and the following IRC-specific ones: $uri->entity,
  $uri->flags, $uri->options.
  
  =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. (Update: as of April 2010, they are in
  L<RFC 5538|https://tools.ietf.org/html/rfc5538>.
  
  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<nntps>:
  
  See I<news> scheme and L<RFC 5538|https://tools.ietf.org/html/rfc5538>.
  
  =item B<otpauth>:
  
  The I<otpauth> URI scheme is specified in L<https://github.com/google/google-authenticator/wiki/Key-Uri-Format>.
  The scheme is used to encode secret keys for use in TOTP or HOTP schemes.
  
  C<URI> objects belonging to the otpauth scheme support the common methods.
  
  =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<smb>:
  
  C<URI> objects belonging to the smb scheme support the common,
  generic and server methods. In addition, they provide methods to
  access the userinfo sub-components ($uri->user and $uri->password)
  as well as $uri->authdomain and $uri->sharename methods.
  
  =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 ENVIRONMENT VARIABLES
  
  =over 4
  
  =item URI_HAS_RESERVED_SQUARE_BRACKETS
  
  Before version 5.11, URI treated square brackets as reserved characters
  throughout the whole URI string. However, these brackets are reserved
  only within the authority/host part of the URI and nowhere else (RFC 3986).
  
  Starting with version 5.11, URI takes this distinction into account.
  Setting the environment variable C<URI_HAS_RESERVED_SQUARE_BRACKETS>
  (programmatically or via the shell), restores the old behavior.
  
    #-- restore 5.10 behavior programmatically
    BEGIN {
      $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} = 1;
    }
    use URI ();
  
  I<Note>: This environment variable is just used during initialization and has to be set
        I<before> module URI is used/required. Changing it at run time has no effect.
  
  Its value can be checked programmatically by accessing the constant
  C<URI::HAS_RESERVED_SQUARE_BRACKETS>.
  
  =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::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\-\._~"
  
  The second argument can also be specified as a regular expression object:
  
    qr/[^A-Za-z]/
  
  Any strings matched by this regular expression will have all of their
  characters escaped.
  
  =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 = '5.32';
  
  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;
      my $re;
      if (defined $patn){
          if (ref $patn eq 'Regexp') {
              $text =~ s{($patn)}{
                  join('', map +($escapes{$_} || _fail_hi($_)), split //, "$1")
              }ge;
              return $text;
          }
          $re = $subst{$patn};
          if (!defined $re) {
              $re = $patn;
              # we need to escape the [] characters, except for those used in
              # posix classes. if they are prefixed by a backslash, allow them
              # through unmodified.
              $re =~ s{(\[:\w+:\])|(\\)?([\[\]]|\\\z)}{
                  defined $1 ? $1 : defined $2 ? "$2$3" : "\\$3"
              }ge;
              eval {
                  # disable the warnings here, since they will trigger later
                  # when used, and we only want them to appear once per call,
                  # but every time the same pattern is used.
                  no warnings 'regexp';
                  $re = $subst{$patn} = qr{[$re]};
                  1;
              } or Carp::croak("uri_escape: $@");
          }
      }
      else {
          $re = $Unsafe{RFC3986};
      }
      $text =~ s/($re)/$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("example");          # http://www.example.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 = '5.32';
  
  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 (
  		m,^//, || m,^[\\][\\],) # UNC-like file name
      {
  		s{[\\]}{/}g;
  		$_ = "smb:$_";
      } 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 = '5.32';
  
  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 = '5.32';
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::QueryParam - Additional query methods for URIs
  
  =head1 SYNOPSIS
  
    use URI;
  
  =head1 DESCRIPTION
  
  C<URI::QueryParam> used to provide the
  L<< query_form_hash|URI/$hashref = $u->query_form_hash >>,
  L<< query_param|URI/@keys = $u->query_param >>
  L<< query_param_append|URI/$u->query_param_append($key, $value,...) >>, and
  L<< query_param_delete|URI/ @values = $u->query_param_delete($key) >> methods
  on L<URI> objects. These methods have been merged into L<URI> itself, so this
  module is now a no-op.
  
  =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 = '5.32';
  
  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.32';
  
  # 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 qw(blessed);
  
  our $VERSION = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  my $ACHAR = URI::HAS_RESERVED_SQUARE_BRACKETS ? $URI::uric : $URI::uric4host;  $ACHAR =~ s,\\[/?],,g;
  my $PCHAR = $URI::uric;                                                        $PCHAR =~ s,\\[?],,g;
  
  sub _no_scheme_ok { 1 }
  
  our $IPv6_re;
  
  sub _looks_like_raw_ip6_address {
    my $addr = shift;
  
    if ( !$IPv6_re ) { #-- lazy / runs once / use Regexp::IPv6 if installed
      eval {
        require Regexp::IPv6;
        Regexp::IPv6->import( qw($IPv6_re) );
        1;
      }  ||  do { $IPv6_re = qr/[:0-9a-f]{3,}/; }; #-- fallback: unambitious guess
    }
  
    return 0 unless $addr;
    return 0 if $addr =~ tr/:/:/ < 2;  #-- fallback must not create false positive for IPv4:Port = 0:0
    return 1 if $addr =~ /^$IPv6_re$/i;
    return 0;
  }
  
  
  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;
              if ( my ($user, $host) = $auth =~ /^(.*@)?([^@]+)$/ ) { #-- special escape userinfo part
                $user ||= '';
                $user =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego;
                $user =~ s/%40$/\@/; # recover final '@'
                $host = "[$host]" if _looks_like_raw_ip6_address( $host );
                $auth = $user . $host;
              }
  	    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(decode_punycode encode_punycode);
  use Carp qw(croak);
  
  our $VERSION = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  # 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 = '5.32';
  
  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);
  use Scalar::Util ();
  
  our $VERSION = '5.32';
  
  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 (_is_array($r)) {
              $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 = [_is_array($vals) ? @$vals : $vals];
              for my $val (@$vals) {
                  if (defined $val) {
                      $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
                      $val =~ s/ /+/g;
                      push(@query, "$key=$val");
                  }
                  else {
                      push(@query, $key);
                  }
              }
          }
          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 { ( defined ) ? do { s/\+/ /g; uri_unescape($_) } : undef }
           map { /=/ ? split(/=/, $_, 2) : ($_ => undef)} 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 && _is_array($copy[0]);
  	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 }
  
  sub 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 { _is_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 query_param_append {
      my $self = shift;
      my $key = shift;
      my @vals = map { _is_array($_) ? @$_ : $_ } @_;
      $self->query_form($self->query_form, $key => \@vals);  # XXX
      return;
  }
  
  sub 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 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 _is_array($_);
                  push(@$_, $v);
              }
          }
          else {
              $hash{$k} = $v;
          }
      }
      return \%hash;
  }
  
  sub _is_array {
      return(
          defined($_[0]) &&
          ( Scalar::Util::reftype($_[0]) || '' ) eq "ARRAY" && 
          !(
              Scalar::Util::blessed( $_[0] ) && 
              overload::Method( $_[0], '""' )
          )
      );
  }
  
  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 = '5.32';
  
  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 = '5.32';
  
  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 if  URI::HAS_RESERVED_SQUARE_BRACKETS  and  $_[0] !~ /[^$URI::uric]/;
    return if !URI::HAS_RESERVED_SQUARE_BRACKETS  and  $_[0] !~ /[^$URI::uric4host]/;
      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/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego;
            $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 = '5.32';
  
  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)) {
  	    $self->userinfo(length $user ? $user : 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 = '5.32';
  
  use MIME::Base64 qw(decode_base64 encode_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 = '5.32';
  
  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,
  see L<RFC 8089|https://www.rfc-editor.org/rfc/rfc8089.html>.
  
  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 L<RFC
  3986|https://www.rfc-editor.org/rfc/rfc3986.html>).
  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 determines 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> forces 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 ();
  
  our $VERSION = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  # 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 = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  use parent qw(URI::_server URI::_userpass);
  
  sub default_port { 21 }
  
  sub encrypt_mode { undef }
  
  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/ftpes.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FTPES';
  package URI::ftpes;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  use parent 'URI::ftp';
  
  sub secure { 1 }
  
  sub encrypt_mode { 'explicit' }
  
  1;
URI_FTPES

$fatpacked{"URI/ftps.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FTPS';
  package URI::ftps;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  use parent 'URI::ftp';
  
  sub default_port { 990 }
  
  sub secure { 1 }
  
  sub encrypt_mode { 'implicit' }
  
  1;
URI_FTPS

$fatpacked{"URI/geo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_GEO';
  package URI::geo;
  
  use warnings;
  use strict;
  
  use Carp;
  use URI::Split qw( uri_split uri_join );
  
  use base qw( URI );
  
  our $VERSION = '5.32';
  
  sub _MINIMUM_LATITUDE      { return -90 }
  sub _MAXIMUM_LATITUDE      { return 90 }
  sub _MINIMUM_LONGITUDE     { return -180 }
  sub _MAXIMUM_LONGITUDE     { return 180 }
  sub _MAX_POINTY_PARAMETERS { return 3 }
  
  sub _can {
      my ($can_pt, @keys) = @_;
      for my $key (@keys) {
          return $key if $can_pt->can($key);
      }
      return;
  }
  
  sub _has {
      my ($has_pt, @keys) = @_;
      for my $key (@keys) {
          return $key if exists $has_pt->{$key};
      }
      return;
  }
  
  # Try hard to extract location information from something. We handle lat,
  # lon, alt as scalars, arrays containing lat, lon, alt, hashes with
  # suitably named keys and objects with suitably named methods.
  
  sub _location_of_pointy_thing {
      my ($class, @parameters) = @_;
  
      my @lat = qw( lat latitude );
      my @lon = qw( lon long longitude lng );
      my @ele = qw( ele alt elevation altitude );
  
      if (ref $parameters[0]) {
          my $pt = shift @parameters;
  
          if (@parameters) {
              croak q[Too many arguments];
          }
  
          if (eval { $pt->can('can') }) {
              for my $m (qw( location latlong )) {
                  return $pt->$m() if _can($pt, $m);
              }
  
              my $latk = _can($pt, @lat);
              my $lonk = _can($pt, @lon);
              my $elek = _can($pt, @ele);
  
              if (defined $latk && defined $lonk) {
                  return $pt->$latk(), $pt->$lonk(),
                      defined $elek ? $pt->$elek() : undef;
              }
          }
          elsif ('ARRAY' eq ref $pt) {
              return $class->_location_of_pointy_thing(@{$pt});
          }
          elsif ('HASH' eq ref $pt) {
  
              my $latk = _has($pt, @lat);
              my $lonk = _has($pt, @lon);
              my $elek = _has($pt, @ele);
  
              if (defined $latk && defined $lonk) {
                  return $pt->{$latk}, $pt->{$lonk},
                      defined $elek ? $pt->{$elek} : undef;
              }
          }
  
          croak q[Don't know how to convert point];
      }
      else {
          croak q[Need lat, lon or lat, lon, alt]
              if @parameters < 2 || @parameters > _MAX_POINTY_PARAMETERS();
          return my ($lat, $lon, $alt) = @parameters;
      }
  }
  
  sub _num {
      my ($class, $n) = @_;
      if (!defined $n) {
          return q[];
      }
      (my $rep = sprintf '%f', $n) =~ s/[.]0*$//smx;
      return $rep;
  }
  
  sub new {
      my ($self, @parameters) = @_;
      my $class = ref $self || $self;
      my $uri   = uri_join 'geo', undef, $class->_path(@parameters);
      return bless \$uri, $class;
  }
  
  sub _init {
      my ($class, $uri, $scheme) = @_;
  
      my $self = $class->SUPER::_init($uri, $scheme);
  
      # Normalise at poles.
      my $lat = $self->latitude;
      if ($lat == _MAXIMUM_LATITUDE() || $lat == _MINIMUM_LATITUDE()) {
          $self->longitude(0);
      }
      return $self;
  }
  
  sub location {
      my ($self, @parameters) = @_;
  
      if (@parameters) {
          my ($lat, $lon, $alt) = @parameters;
          return $self->latitude($lat)->longitude($lon)->altitude($alt);
      }
  
      return $self->latitude, $self->longitude, $self->altitude;
  }
  
  sub latitude {
      my ($self, @parameters) = @_;
      return $self->field('latitude', @parameters);
  }
  
  sub longitude {
      my ($self, @parameters) = @_;
      return $self->field('longitude', @parameters);
  }
  
  sub altitude {
      my ($self, @parameters) = @_;
      return $self->field('altitude', @parameters);
  }
  
  sub crs {
      my ($self, @parameters) = @_;
      return $self->field('crs', @parameters);
  }
  
  sub uncertainty {
      my ($self, @parameters) = @_;
      return $self->field('uncertainty', @parameters);
  }
  
  sub field {
      my ($self, $name, @remainder) = @_;
      my ($scheme, $auth, $v, $query, $frag) = $self->_parse;
  
      if (!exists $v->{$name}) {
          croak "No such field: $name";
      }
      if (!@remainder) {
          return $v->{$name};
      }
      $v->{$name} = shift @remainder;
      ${$self} = uri_join $scheme, $auth, $self->_format($v), $query, $frag;
      return $self;
  }
  
  {
      my $pnum = qr{\d+(?:[.]\d+)?}smx;
      my $num  = qr{-?$pnum}smx;
      my $crsp = qr{(?:;crs=(\w+))}smx;
      my $uncp = qr{(?:;u=($pnum))}smx;
      my $parm = qr{(?:;\w+=[^;]*)+}smx;
  
      sub _parse {
          my $self = shift;
          my ($scheme, $auth, $path, $query, $frag) = uri_split ${$self};
  
          $path =~ m{^ ($num), ($num) (?: , ($num) ) ?
                     (?: $crsp ) ?
                     (?: $uncp ) ?
                     ( $parm ) ? 
                  $}smx or croak 'Badly formed geo uri';
  
          # No named captures before 5.10.0
          return $scheme, $auth,
              {
              latitude    => $1,
              longitude   => $2,
              altitude    => $3,
              crs         => $4,
              uncertainty => $5,
              parameters  => (defined $6 ? substr $6, 1 : undef),
              },
              $query, $frag;
      }
  }
  
  sub _format {
      my ($class, $v) = @_;
      return join q[;],
          (
          join q[,],
          map { $class->_num($_) } @{$v}{'latitude', 'longitude'},
          (defined $v->{altitude} ? ($v->{altitude}) : ())
          ),
          (defined $v->{crs} ? ('crs=' . $class->_num($v->{crs})) : ()),
          (
          defined $v->{uncertainty}
          ? ('u=' . $class->_num($v->{uncertainty}))
          : ()), (defined $v->{parameters} ? ($v->{parameters}) : ());
  }
  
  sub _path {
      my ($class, @parameters) = @_;
      my ($lat, $lon, $alt) = $class->_location_of_pointy_thing(@parameters);
      croak 'Latitude out of range'
          if $lat < _MINIMUM_LATITUDE() || $lat > _MAXIMUM_LATITUDE();
      croak 'Longitude out of range'
          if $lon < _MINIMUM_LONGITUDE() || $lon > _MAXIMUM_LONGITUDE();
      if ($lat == _MINIMUM_LATITUDE() || $lat == _MAXIMUM_LATITUDE()) {
          $lat = 0;
      }
      return $class->_format(
          {latitude => $lat, longitude => $lon, altitude => $alt});
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::geo - URI scheme for geo Identifiers
  
  =head1 SYNOPSIS
  
    use URI;
  
    # Geo URI from textual uri
    my $guri = URI->new( 'geo:54.786989,-2.344214' );
  
    # From coordinates
    my $guri = URI::geo->new( 54.786989, -2.344214 );
  
    # Decode
    my ( $lat, $lon, $alt ) = $guri->location;
    my $latitude = $guri->latitude;
  
    # Update
    $guri->location( 55, -1 );
    $guri->longitude( -43.23 );
    
  =head1 DESCRIPTION
  
  From L<http://geouri.org/>:
  
    More and more protocols and data formats are being extended by methods
    to add geographic information. However, all of those options are tied
    to that specific protocol or data format.
  
    A dedicated Uniform Resource Identifier (URI) scheme for geographic
    locations would be independent from any protocol, usable by any
    software/data format that can handle generich URIs. Like a "mailto:"
    URI launches your favourite mail application today, a "geo:" URI could
    soon launch your favourite mapping service, or queue that location for
    a navigation device.
  
  =head1 SUBROUTINES/METHODS
  
  =head2 C<< new >>
  
  Create a new URI::geo. The arguments should be either
  
  =over
  
  =item * latitude, longitude and optionally altitude
  
  =item * a reference to an array containing lat, lon, alt
  
  =item * a reference to a hash with suitably named keys or
  
  =item * a reference to an object with suitably named accessors
  
  =back
  
  To maximize the likelihood that you can pass in some object that
  represents a geographical location and have URI::geo do the right thing
  we try a number of different accessor names.
  
  If the object has a C<latlong> method (e.g. L<Geo::Point>) we'll use that.
  If there's a C<location> method we call that. Otherwise we look for
  accessors called C<lat>, C<latitude>, C<lon>, C<long>, C<longitude>,
  C<ele>, C<alt>, C<elevation> or C<altitude> and use them.
  
  Often if you have an object or hash reference that represents a point
  you can pass it directly to C<new>; so for example this will work:
  
    use URI::geo;
    use Geo::Point;
  
    my $pt = Geo::Point->latlong( 48.208333, 16.372778 );
    my $guri = URI::geo->new( $pt );
  
  As will this:
  
    my $guri = URI::geo->new( { lat => 55, lon => -1 } );
  
  and this:
  
    my $guri = URI::geo->new( 55, -1 );
  
  Note that you can also create a new C<URI::geo> by passing a Geo URI to
  C<URI::new>:
  
    use URI;
  
    my $guri = URI->new( 'geo:55,-1' );
  
  =head2 C<location>
  
  Get or set the location of this geo URI.
  
    my ( $lat, $lon, $alt ) = $guri->location;
    $guri->location( 55.3, -3.7, 120 );
  
  When setting the location it is possible to pass any of the argument
  types that can be passed to C<new>.
  
  =head2 C<latitude>
  
  Get or set the latitude of this geo URI.
  
  =head2 C<longitude>
  
  Get or set the longitude of this geo URI.
  
  =head2 C<altitude>
  
  Get or set the L<altitude|https://en.wikipedia.org/wiki/Geo_URI_scheme#Altitude> of this geo URI. To delete the altitude set it to C<undef>.
  
  =head2 C<crs>
  
  Get or set the L<Coordinate Reference System|https://en.wikipedia.org/wiki/Geo_URI_scheme#Coordinate_reference_systems> of this geo URI. To delete the CRS set it to C<undef>.
  
  =head2 C<uncertainty>
  
  Get or set the L<uncertainty|https://en.wikipedia.org/wiki/Geo_URI_scheme#Uncertainty> of this geo URI. To delete the uncertainty set it to C<undef>.
  
  =head2 C<field>
  
  =head1 CONFIGURATION AND ENVIRONMENT
  
  URI::geo requires no configuration files or environment variables.
  
  =head1 DEPENDENCIES
  
  L<URI>
  
  =head1 DIAGNOSTICS
  
  =over
   
  =item C<< Too many arguments >>
   
  The L<new|/new> method can only accept three parameters; latitude, longitude and altitude.
   
  =item C<< Don't know how to convert point >>
  
  The L<new|/new> method doesn't know how to convert the supplied parameters into a URI::geo object.
  
  =item C<< Need lat, lon or lat, lon, alt >>
  
  The L<new|/new> method needs two (latitude and longitude) or three (latitude, longitude and altitude) parameters in a list.  Any less or more than this is an error.
  
  =item C<< No such field: %s >>
  
  This field is not a known field for the L<URI::geo|URI::geo> object.
  
  =item C<< Badly formed geo uri >>
  
  The L<URI|URI> cannot be parsed as a URI
  
  =item C<< Badly formed geo uri >>
  
  The L<URI|URI> cannot be parsed as a URI
  
  =item C<< Latitude out of range >>
  
  Latitude may only be from -90 to +90
  
  =item C<< Longitude out of range >>
  
  Longitude may only be from -180 to +180
  
  =back
  
  =head1 INCOMPATIBILITIES
  
  None reported.
  
  =head1 BUGS AND LIMITATIONS
  
  To report a bug, or view the current list of bugs, please visit L<https://github.com/libwww-perl/URI/issues>
  
  =head1 AUTHOR
  
  Andy Armstrong  C<< <andy@hexten.net> >>
  
  =head1 LICENSE AND COPYRIGHT
  
  Copyright (c) 2009, Andy Armstrong C<< <andy@hexten.net> >>.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
URI_GEO

$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 = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  use parent 'URI::http';
  
  sub default_port { 443 }
  
  sub secure { 1 }
  
  1;
URI_HTTPS

$fatpacked{"URI/icap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_ICAP';
  package URI::icap;
  
  use strict;
  use warnings;
  use base qw(URI::http);
  
  our $VERSION = '5.32';
  
  sub default_port { return 1344 }
  
  1;
  __END__
  
  =head1 NAME
  
  URI::icap - URI scheme for ICAP Identifiers
  
  =head1 VERSION
  
  Version 5.20
  
  =head1 SYNOPSIS
  
      use URI::icap;
  
      my $uri = URI->new('icap://icap-proxy.example.com/');
  
  =head1 DESCRIPTION
  
  This module implements the C<icap:> URI scheme defined in L<RFC 3507|http://tools.ietf.org/html/rfc3507>, for the L<Internet Content Adaptation Protocol|https://en.wikipedia.org/wiki/Internet_Content_Adaptation_Protocol>.
  
  =head1 SUBROUTINES/METHODS
  
  This module inherits the behaviour of L<URI::http|URI::http> and overrides the L<default_port|URI#$uri->default_port> method.
  
  =head2 default_port
  
  The default port for icap servers is 1344
  
  =head1 DIAGNOSTICS
  
  See L<URI|URI>
  
  =head1 CONFIGURATION AND ENVIRONMENT
  
  See L<URI|URI#CONFIGURATION-VARIABLES> and L<URI|URI#ENVIRONMENT-VARIABLES>
  
  =head1 DEPENDENCIES
  
  None
  
  =head1 INCOMPATIBILITIES
  
  None reported
  
  =head1 BUGS AND LIMITATIONS
  
  See L<URI|URI#BUGS>
  
  =head1 SEE ALSO
  
  L<RFC 3507|http://tools.ietf.org/html/rfc3507>
  
  =head1 AUTHOR
  
  David Dick, C<< <ddick at cpan.org> >>
  
  =head1 LICENSE AND COPYRIGHT
  
  Copyright 2016 David Dick.
  
  This program is free software; you can redistribute it and/or modify it
  under the terms of either: the GNU General Public License as published
  by the Free Software Foundation; or the Artistic License.
  
  See L<http://dev.perl.org/licenses/> for more information.
URI_ICAP

$fatpacked{"URI/icaps.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_ICAPS';
  package URI::icaps;
  
  use strict;
  use warnings;
  use base qw(URI::icap);
  
  our $VERSION = '5.32';
  
  sub secure { return 1 }
  
  1;
  __END__
  
  =head1 NAME
  
  URI::icaps - URI scheme for ICAPS Identifiers
  
  =head1 VERSION
  
  Version 5.20
  
  =head1 SYNOPSIS
  
      use URI::icaps;
  
      my $uri = URI->new('icaps://icap-proxy.example.com/');
  
  =head1 DESCRIPTION
  
  This module implements the C<icaps:> URI scheme defined in L<RFC 3507|http://tools.ietf.org/html/rfc3507>, for the L<Internet Content Adaptation Protocol|https://en.wikipedia.org/wiki/Internet_Content_Adaptation_Protocol>.
  
  =head1 SUBROUTINES/METHODS
  
  This module inherits the behaviour of L<URI::icap|URI::icap> and overrides the L<secure|URI#$uri->secure> method.
  
  =head2 secure
  
  returns 1 as icaps is a secure protocol
  
  =head1 DIAGNOSTICS
  
  See L<URI::icap|URI::icap>
  
  =head1 CONFIGURATION AND ENVIRONMENT
  
  See L<URI::icap|URI::icap>
  
  =head1 DEPENDENCIES
  
  None
  
  =head1 INCOMPATIBILITIES
  
  None reported
  
  =head1 BUGS AND LIMITATIONS
  
  See L<URI::icap|URI::icap>
  
  =head1 SEE ALSO
  
  L<RFC 3507|http://tools.ietf.org/html/rfc3507>
  
  =head1 AUTHOR
  
  David Dick, C<< <ddick at cpan.org> >>
  
  =head1 LICENSE AND COPYRIGHT
  
  Copyright 2016 David Dick.
  
  This program is free software; you can redistribute it and/or modify it
  under the terms of either: the GNU General Public License as published
  by the Free Software Foundation; or the Artistic License.
  
  See L<http://dev.perl.org/licenses/> for more information.
URI_ICAPS

$fatpacked{"URI/irc.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_IRC';
  package URI::irc;  # draft-butcher-irc-url-04
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  use parent 'URI::_login';
  
  use overload (
     '""'     => sub { $_[0]->as_string  },
     '=='     => sub {  URI::_obj_eq(@_) },
     '!='     => sub { !URI::_obj_eq(@_) },
     fallback => 1,
  );
  
  sub default_port { 6667 }
  
  #   ircURL   = ircURI "://" location "/" [ entity ] [ flags ] [ options ]
  #   ircURI   = "irc" / "ircs"
  #   location = [ authinfo "@" ] hostport
  #   authinfo = [ username ] [ ":" password ]
  #   username = *( escaped / unreserved )
  #   password = *( escaped / unreserved ) [ ";" passtype ]
  #   passtype = *( escaped / unreserved )
  #   entity   = [ "#" ] *( escaped / unreserved )
  #   flags    = ( [ "," enttype ] [ "," hosttype ] )
  #           /= ( [ "," hosttype ] [ "," enttype ] )
  #   enttype  = "," ( "isuser" / "ischannel" )
  #   hosttype = "," ( "isserver" / "isnetwork" )
  #   options  = "?" option *( "&" option )
  #   option   = optname [ "=" optvalue ]
  #   optname  = *( ALPHA / "-" )
  #   optvalue = optparam *( "," optparam )
  #   optparam = *( escaped / unreserved )
  
  # XXX: Technically, passtype is part of the protocol, but is rarely used and
  # not defined in the RFC beyond the URL ABNF.
  
  # Starting the entity with /# is okay per spec, but it needs to be encoded to
  # %23 for the URL::_generic::path operations to parse correctly.
  sub _init {
      my $class = shift;
      my $self = $class->SUPER::_init(@_);
      $$self =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/\#|$1/%23|s;
      $self;
  }
  
  # Return the /# form, since this is most common for channel names.
  sub path {
      my $self = shift;
      my ($new) = @_;
      $new =~ s|^/\#|/%23| if (@_ && defined $new);
      my $val = $self->SUPER::path(@_ ? $new : ());
      $val =~ s|^/%23|/\#|;
      $val;
  }
  sub path_query {
      my $self = shift;
      my ($new) = @_;
      $new =~ s|^/\#|/%23| if (@_ && defined $new);
      my $val = $self->SUPER::path_query(@_ ? $new : ());
      $val =~ s|^/%23|/\#|;
      $val;
  }
  sub as_string {
      my $self = shift;
      my $val = $self->SUPER::as_string;
      $val =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/%23|$1/\#|s;
      $val;
  }
  
  sub entity {
      my $self = shift;
  
      my $path = $self->path;
      $path =~ s|^/||;
      my ($entity, @flags) = split /,/, $path;
  
      if (@_) {
          my $new = shift;
          $new = '' unless defined $new;
          $self->path( '/'.join(',', $new, @flags) );
      }
  
      return unless length $entity;
      $entity;
  }
  
  sub flags {
      my $self = shift;
  
      my $path = $self->path;
      $path =~ s|^/||;
      my ($entity, @flags) = split /,/, $path;
  
      if (@_) {
          $self->path( '/'.join(',', $entity, @_) );
      }
  
      @flags;
  }
  
  sub options { shift->query_form(@_) }
  
  sub canonical {
      my $self = shift;
      my $other = $self->SUPER::canonical;
  
      # Clean up the flags
      my $path = $other->path;
      $path =~ s|^/||;
      my ($entity, @flags) = split /,/, $path;
  
      my @clean =
          map { $_ eq 'isnick' ? 'isuser' : $_ }  # convert isnick->isuser
          map { lc }
          # NOTE: Allow flags from draft-mirashi-url-irc-01 as well
          grep { /^(?:is(?:user|channel|server|network|nick)|need(?:pass|key))$/i }
          @flags
      ;
  
      # Only allow the first type of each category, per the Butcher draft
      my ($enttype)  = grep { /^is(?:user|channel)$/   } @clean;
      my ($hosttype) = grep { /^is(?:server|network)$/ } @clean;
      my @others     = grep { /^need(?:pass|key)$/ }     @clean;
  
      my @new = (
          $enttype  ? $enttype  : (),
          $hosttype ? $hosttype : (),
          @others,
      );
  
      unless (join(',', @new) eq join(',', @flags)) {
          $other = $other->clone if $other == $self;
          $other->path( '/'.join(',', $entity, @new) );
      }
  
      $other;
  }
  
  1;
URI_IRC

$fatpacked{"URI/ircs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_IRCS';
  package URI::ircs;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  use parent 'URI::irc';
  
  sub default_port { 994 }
  
  sub secure { 1 }
  
  1;
URI_IRCS

$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 = '5.32';
  
  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 = '5.32';
  
  use parent qw(URI::_ldap URI::_generic);
  
  use 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 = '5.32';
  
  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 = '5.32';
  
  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;
  }
  
  # https://datatracker.ietf.org/doc/html/rfc6068#section-5 requires 
  # plus signs (+) not to be turned into spaces
  sub query_form 
  {
      my $self   = shift;
      my @fields = $self->SUPER::query_form(@_);
      for ( my $i = 0 ; $i < @fields ; $i += 2 ) {
          if ( $fields[0] eq 'to' ) {
              $fields[1] =~ s/ /+/g;
              last;
          }
      }
      return @fields;
  }
  
  1;
URI_MAILTO

$fatpacked{"URI/mms.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_MMS';
  package URI::mms;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  use parent 'URI::news';
  
  1;
URI_NNTP

$fatpacked{"URI/nntps.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_NNTPS';
  package URI::nntps;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  use parent 'URI::nntp';
  
  sub default_port { 563 }
  
  sub secure { 1 }
  
  1;
URI_NNTPS

$fatpacked{"URI/otpauth.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_OTPAUTH';
  package URI::otpauth;
  
  use warnings;
  use strict;
  use MIME::Base32();
  use URI::Split();
  use URI::Escape();
  
  use parent qw( URI URI::_query );
  
  our $VERSION = '5.32';
  
  sub new {
      my ($class, @parameters) = @_;
      my %fields = $class->_set(@parameters);
      my $uri    = URI::Split::uri_join(
          'otpauth', $fields{type},
          $class->_path(%fields),
          $class->_query(%fields),
      );
      return bless \$uri, $class;
  }
  
  sub _parse {
      my $self = shift;
      my ($scheme, $type, $path, $query, $frag) = URI::Split::uri_split(${$self});
      $path =~ s/^\///smxg;
      my @path_parts = split /:/smx, $path;
      my ($issuer_prefix, $account_name);
      if (scalar @path_parts == 1) {
          $account_name = $path_parts[0];
      }
      else {
          $issuer_prefix = $path_parts[0];
          $account_name  = $path_parts[1];
      }
      my %fields = (label => $path, type => $type, account_name => $account_name);
      my $issuer_parameter = $self->query_param('issuer');
      if (defined $issuer_parameter) {
          if ((defined $issuer_prefix) && ($issuer_prefix ne $issuer_parameter)) {
              Carp::carp(
                  "Issuer prefix from label '$issuer_prefix' does not match issuer parameter '$issuer_parameter'"
              );
          }
          $fields{issuer} = $issuer_parameter;
      }
      elsif (defined $issuer_prefix) {
          $fields{issuer} = URI::Escape::uri_unescape($issuer_prefix);
      }
      if (my $encoded_secret = $self->query_param('secret')) {
          $fields{secret} = MIME::Base32::decode_base32($encoded_secret);
      }
      foreach my $name (qw(algorithm digits counter period)) {
          if (my $value = $self->query_param($name)) {
              $fields{$name} = $value;
          }
      }
      %fields = $self->_set(%fields);
      return ($scheme, $fields{type}, \%fields, $query, $frag);
  }
  
  my $label_escape_regex = qr/[^[:alnum:]@.]/smx;
  
  sub _set {
      my ($self, %fields) = @_;
      delete $fields{label};
      if (defined $fields{account_name}) {
          if (defined $fields{issuer}) {
              $fields{label} = $fields{issuer} . q[:] . $fields{account_name};
          }
          else {
              $fields{label} = $fields{account_name};
          }
      }
      if (!length $fields{type}) {
          $fields{type} = 'totp';
      }
      return %fields;
  }
  
  my %field_names = map { $_ => 1 }
      qw(secret label counter algorithm period digits issuer type account_name);
  my @query_names = qw(secret issuer algorithm digits counter period);
  my %defaults = (algorithm => 'SHA1', digits => 6, type => 'totp', period => 30);
  
  sub _field {
      my ($self, $name, @remainder) = @_;
      my ($scheme, $type, $fields, $query, $frag) = $self->_parse();
  
      if (!@remainder) {
          if (defined $fields->{$name}) {
              return $fields->{$name};
          }
          else {
              return $defaults{$name};
          }
      }
      $fields->{$name} = shift @remainder;
      ${$self} = URI::Split::uri_join(
          $scheme, $fields->{type},
          $self->_path(%{$fields}),
          $self->_query(%{$fields}), $frag
      );
      return $self;
  }
  
  sub _query {
      my ($class, %fields) = @_;
      if (defined $fields{secret}) {
          $fields{secret} = MIME::Base32::encode_base32($fields{secret});
      }
      else {
          Carp::croak('secret is a mandatory parameter for ' . __PACKAGE__);
      }
      return join q[&],
          map { join q[=], $_ => $fields{$_} }
          grep { exists $fields{$_} } @query_names;
  }
  
  sub _path {
      my ($class, %fields) = @_;
      my $path = $fields{label};
      return $path;
  }
  
  sub type {
      my ($self, @parameters) = @_;
      return $self->_field('type', @parameters);
  }
  
  sub authority { return shift->type(@_); }
  
  sub label {
      my ($self, @parameters) = @_;
      return $self->_field('label', @parameters);
  }
  
  sub account_name {
      my ($self, @parameters) = @_;
      return $self->_field('account_name', @parameters);
  }
  
  sub issuer {
      my ($self, @parameters) = @_;
      return $self->_field('issuer', @parameters);
  }
  
  sub secret {
      my ($self, @parameters) = @_;
      return $self->_field('secret', @parameters);
  }
  
  sub algorithm {
      my ($self, @parameters) = @_;
      return $self->_field('algorithm', @parameters);
  }
  
  sub counter {
      my ($self, @parameters) = @_;
      return $self->_field('counter', @parameters);
  }
  
  sub digits {
      my ($self, @parameters) = @_;
      return $self->_field('digits', @parameters);
  }
  
  sub period {
      my ($self, @parameters) = @_;
      return $self->_field('period', @parameters);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  URI::otpauth - URI scheme for secret keys for OTP secrets.  Usually found in QR codes
  
  =head1 VERSION
  
  Version 5.29
  
  =head1 SYNOPSIS
  
    use URI;
  
    # optauth URI from textual uri
    my $uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=NFZS25DINFZV643VOAZXELLTGNRXEM3UH4&issuer=Example' );
  
    # same URI but created from arguments
    my $uri = URI::otpauth->new( type => 'totp', issuer => 'Example', account_name => 'alice@google.com', secret => 'is-this_sup3r-s3cr3t?' );
    
  =head1 DESCRIPTION
  
  This URI scheme is defined in L<https://github.com/google/google-authenticator/wiki/Key-Uri-Format/>:
  
  =head1 SUBROUTINES/METHODS
  
  =head2 C<< new >>
  
  Create a new URI::otpauth. The available arguments are listed below;
  
  =over
  
  =item * account_name - this can be the account name (probably an email address) used when authenticating with this secret.  It is an optional field.
  
  =item * algorithm - this is the L<cryptographic hash function|https://en.wikipedia.org/wiki/Cryptographic_hash_function> that should be used.  Current values are L<SHA1|https://en.wikipedia.org/wiki/SHA-1>, L<SHA256|https://en.wikipedia.org/wiki/SHA-2> or L<SHA512|https://en.wikipedia.org/wiki/SHA-2>.  It is an optional field and will default to SHA1.
  
  =item * counter - this is only required when the type is HOTP.
  
  =item * digits - this determines the L<length|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#digits> of the code presented to the user.  It is an optional field and will default to 6 digits.
  
  =item * issuer - this can be the L<application / system|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#issuer> that this secret can be used to authenticate to.  It is an optional field.
  
  =item * label - this is the L<issuer and the account name|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#label> joined with a ":" character.  It is an optional field.
  
  =item * period - this is the L<period that the TOTP code is valid for|https://github.com/google/google-authenticator/wiki/Key-Uri-Format/#counter>.  It is an optional field and will default to 30 seconds.
  
  =item * secret - this is the L<key|https://en.wikipedia.org/wiki/Key_(cryptography)> that the L<TOTP|https://en.wikipedia.org/wiki/Time-based_one-time_password>/L<HOTP|https://en.wikipedia.org/wiki/HMAC-based_one-time_password> algorithm uses to derive the value.  It is an arbitrary byte string and must remain private.  This field is mandatory.
  
  =item * type - this can be 'L<hotp|https://en.wikipedia.org/wiki/HMAC-based_one-time_password>' or 'L<totp|https://en.wikipedia.org/wiki/Time-based_one-time_password>'.  This field will default to 'totp'.
  
  =back
  
  =head2 C<algorithm>
  
  Get or set the algorithm of this otpauth URI.
  
  =head2 C<account_name>
  
  Get or set the account_name of this otpauth URI.
  
  =head2 C<counter>
  
  Get or set the counter of this otpauth URI.
  
  =head2 C<digits>
  
  Get or set the digits of this otpauth URI.
  
  =head2 C<issuer>
  
  Get or set the issuer of this otpauth URI.
  
  =head2 C<label>
  
  Get or set the label of this otpauth URI.
  
  =head2 C<period>
  
  Get or set the period of this otpauth URI.
  
  =head2 C<secret>
  
  Get or set the secret of this otpauth URI.
  
  =head2 C<type>
  
  Get or set the type of this otpauth URI.
  
    my $type = $uri->type('hotp');
  
  =head1 CONFIGURATION AND ENVIRONMENT
  
  URI::otpauth requires no configuration files or environment variables.
  
  =head1 DEPENDENCIES
  
  L<URI>
  
  =head1 DIAGNOSTICS
  
  =over
   
  =item C<< secret is a mandatory parameter for URI::otpauth >>
   
  The secret parameter was not detected for the URI::otpauth->new() method.
   
  =back
  
  =head1 INCOMPATIBILITIES
  
  None reported.
  
  =head1 BUGS AND LIMITATIONS
  
  To report a bug, or view the current list of bugs, please visit L<https://github.com/libwww-perl/URI/issues>
  
  =head1 AUTHOR
  
  David Dick C<< <ddick@cpan.org> >>
  
  =head1 LICENSE AND COPYRIGHT
  
  Copyright (c) 2024, David Dick C<< <ddick@cpan.org> >>.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
URI_OTPAUTH

$fatpacked{"URI/pop.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_POP';
  package URI::pop;   # RFC 2384
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  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 = '5.32';
  
  use parent 'URI::rtsp';
  
  sub default_port { 554 }
  
  1;
URI_RTSPU

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

$fatpacked{"URI/sftp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SFTP';
  package URI::sftp;
  
  use strict;
  use warnings;
  
  our $VERSION = '5.32';
  
  use parent 'URI::ssh';
  
  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 ();
  
  our $VERSION = '5.32';
  
  sub default_port { 5060 }
  
  sub authority
  {
      my $self = shift;
      $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
      my $start = $1;
      my $authoritystr = $2;
      my $rest = $3;
  
      if (@_) {
          $authoritystr = shift;
          $authoritystr =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
          $$self = $start . $authoritystr . $rest;
      }
      return $authoritystr;
  }
  
  sub params_form
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
      my $start = $1 . $2;
      my $paramstr = $3;
      my $rest = $4;
  
      if (@_) {
  	my @paramarr;
  	for (my $i = 0; $i < @_; $i += 2) {
  	    push(@paramarr, "$_[$i]=$_[$i+1]");
  	}
  	$paramstr = join(";", @paramarr);
  	$$self = $start . ";" . $paramstr . $rest;
      }
      $paramstr =~ s/^;//o;
      return split(/[;=]/, $paramstr);
  }
  
  sub params
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
      my $start = $1 . $2;
      my $paramstr = $3;
      my $rest = $4;
  
      if (@_) {
          $paramstr = shift; 
          $$self = $start . ";" . $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 = '5.32';
  
  use parent 'URI::sip';
  
  sub default_port { 5061 }
  
  sub secure { 1 }
  
  1;
URI_SIPS

$fatpacked{"URI/smb.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SMB';
  package URI::smb;
  
  use strict;
  use warnings;
  
  use parent 'URI::_login';
  
  our $VERSION = '5.32';
  
  sub default_port { 445 }
  
  sub user {
      my $self = shift;
      my $new = shift;
      my ($user, $authdomain) = _parse_user($self->SUPER::user());
      if ($new) {
          $self->SUPER::user($authdomain ? "$authdomain;$new" : $new);
          $user = $new;
      }
      return $user;
  }
  
  sub authdomain {
      my $self = shift;
      my $new = shift;
      my ($user, $authdomain) = _parse_user($self->SUPER::user());
  
      # it must not be possible to set authdomain without user
      if ($user && $new) {
          $self->SUPER::user("$new;$user");
          $authdomain = $new;
      }
      return $authdomain;
  }
  
  sub sharename {
      return (shift->path_segments)[1];
  }
  
  sub _parse_user {
      my $input = shift or return;
      my ($authdomain, $user) = split ';', $input, 2; 
      return $user ? ($user, $authdomain) : $authdomain;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  URI::smb - Samba/CIFS URI scheme
  
  =head1 SYNOPSIS
  
      my $uri = URI->new('smb://authdomain;user:password@server/share/path');
  
  =head1 DESCRIPTION
  
  This module implements the (unofficial) C<smb:> URI scheme described in L<http://www.ubiqx.org/cifs/Appendix-D.html>.
  
  =head1 SUBROUTINES/METHODS
  
  =head2 default_port
  
  The default port for accessing Samba/Windows File Servers is 445
  
  =head2 user
  
  Get or set the user part of the URI (without the authdomain)
  
  =head2 authdomain
  
  Get or set the authentication authdomain part of the URI. This value is only available if the user is already set.
  
  =head2 sharename
  
  Helper method to get the share name from path
  
  =head1 DEPENDENCIES
  
  None
  
  =head1 BUGS AND LIMITATIONS
  
  See L<URI|URI#BUGS>
  
  =head1 SEE ALSO
  
  L<http://www.ubiqx.org/cifs/Appendix-D.html>
  
  =head1 AUTHOR
  
  I. M. Bur <github@lty.cz>
  
  =head1 LICENSE AND COPYRIGHT
  
  This program is free software; you can redistribute it and/or modify it
  under the terms of either: the GNU General Public License as published
  by the Free Software Foundation; or the Artistic License.
  
  See L<http://dev.perl.org/licenses/> for more information.
URI_SMB

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

s/^  //mg for values %fatpacked;

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

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      my $pos = 0;
      my $last = length $fat;
      return (sub {
        return 0 if $pos == $last;
        my $next = (1 + index $fat, "\n", $pos) || $last;
        $_ .= substr $fat, $pos, $next - $pos;
        $pos = $next;
        return 1;
      });
    }
  };
}

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

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

use strict;
use 5.008001;
use Carton::CLI;
$Carton::Fatpacked = 1;
exit Carton::CLI->new->run(@ARGV);
