#!/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{"App/Installer.pm"} = <<'APP_INSTALLER';
  package App::Installer;
  BEGIN {
    $App::Installer::AUTHORITY = 'cpan:GETTY';
  }
  {
    $App::Installer::VERSION = '0.006';
  }
  # ABSTRACT: Application class for Installer
  
  use Moo;
  use Path::Class;
  use IO::All;
  use namespace::clean;
  
  has target => (
    is => 'ro',
    required => 1,
  );
  
  has file => (
    is => 'ro',
    lazy => 1,
    default => sub { '.installer' },
  );
  
  has installer_code => (
    is => 'ro',
    predicate => 1,
  );
  
  has 'url' => (
    is => 'ro',
    predicate => 1,
  );
  
  sub install_to_target {
    my ( $self ) = @_;
    my $target = $self->target;
    $target = dir($target)->absolute->stringify;
    my $installer_code;
    if ($self->has_installer_code) {
      $installer_code = $self->installer_code;
    } elsif ($self->has_url) {
      $installer_code = io($self->url)->get->content;
    } else {
      $installer_code = io($self->file)->all;
    }
    my $target_class = 'App::Installer::Sandbox'.$$;
  
    my ( $err );
    {
      local $@;
      eval <<EVAL;
  package $target_class;
  no strict;
  no warnings;
  use Installer;
  
  install_to '$target' => sub {
    $installer_code;
  };
  
  EVAL
      $err = $@;
    }
  
    if ($err) { die "$err" };
  
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  App::Installer - Application class for Installer
  
  =head1 VERSION
  
  version 0.006
  
  =head1 DESCRIPTION
  
  See L<installer> and for more information
  
  =encoding utf8
  
  =head1 AUTHOR
  
  Torsten Raudssus <torsten@raudss.us>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Torsten Raudssus.
  
  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
APP_INSTALLER

$fatpacked{"Archive/Extract.pm"} = <<'ARCHIVE_EXTRACT';
  package Archive::Extract;
  use if $] > 5.017, 'deprecate';
  
  use strict;
  
  use Cwd                         qw[cwd chdir];
  use Carp                        qw[carp];
  use IPC::Cmd                    qw[run can_run];
  use FileHandle;
  use File::Path                  qw[mkpath];
  use File::Spec;
  use File::Basename              qw[dirname basename];
  use Params::Check               qw[check];
  use Module::Load::Conditional   qw[can_load check_install];
  use Locale::Maketext::Simple    Style => 'gettext';
  
  ### solaris has silly /bin/tar output ###
  use constant ON_SOLARIS     => $^O eq 'solaris' ? 1 : 0;
  use constant ON_NETBSD      => $^O eq 'netbsd' ? 1 : 0;
  use constant ON_OPENBSD     => $^O eq 'openbsd' ? 1 : 0;
  use constant ON_FREEBSD     => $^O =~ m!^(free|midnight)bsd$! ? 1 : 0;
  use constant ON_LINUX       => $^O eq 'linux' ? 1 : 0;
  use constant FILE_EXISTS    => sub { -e $_[0] ? 1 : 0 };
  
  ### VMS may require quoting upper case command options
  use constant ON_VMS         => $^O eq 'VMS' ? 1 : 0;
  
  ### Windows needs special treatment of Tar options
  use constant ON_WIN32       => $^O eq 'MSWin32' ? 1 : 0;
  
  ### we can't use this extraction method, because of missing
  ### modules/binaries:
  use constant METHOD_NA      => [];
  
  ### If these are changed, update @TYPES and the new() POD
  use constant TGZ            => 'tgz';
  use constant TAR            => 'tar';
  use constant GZ             => 'gz';
  use constant ZIP            => 'zip';
  use constant BZ2            => 'bz2';
  use constant TBZ            => 'tbz';
  use constant Z              => 'Z';
  use constant LZMA           => 'lzma';
  use constant XZ             => 'xz';
  use constant TXZ            => 'txz';
  
  use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
              $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
           ];
  
  $VERSION            = '0.68';
  $PREFER_BIN         = 0;
  $WARN               = 1;
  $DEBUG              = 0;
  $_ALLOW_PURE_PERL   = 1;    # allow pure perl extractors
  $_ALLOW_BIN         = 1;    # allow binary extractors
  $_ALLOW_TAR_ITER        = 1;    # try to use Archive::Tar->iter if available
  
  # same as all constants
  my @Types           = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA, XZ, TXZ );
  
  local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
  
  =pod
  
  =head1 NAME
  
  Archive::Extract - A generic archive extracting mechanism
  
  =head1 SYNOPSIS
  
      use Archive::Extract;
  
      ### build an Archive::Extract object ###
      my $ae = Archive::Extract->new( archive => 'foo.tgz' );
  
      ### extract to cwd() ###
      my $ok = $ae->extract;
  
      ### extract to /tmp ###
      my $ok = $ae->extract( to => '/tmp' );
  
      ### what if something went wrong?
      my $ok = $ae->extract or die $ae->error;
  
      ### files from the archive ###
      my $files   = $ae->files;
  
      ### dir that was extracted to ###
      my $outdir  = $ae->extract_path;
  
  
      ### quick check methods ###
      $ae->is_tar     # is it a .tar file?
      $ae->is_tgz     # is it a .tar.gz or .tgz file?
      $ae->is_gz;     # is it a .gz file?
      $ae->is_zip;    # is it a .zip file?
      $ae->is_bz2;    # is it a .bz2 file?
      $ae->is_tbz;    # is it a .tar.bz2 or .tbz file?
      $ae->is_lzma;   # is it a .lzma file?
      $ae->is_xz;     # is it a .xz file?
      $ae->is_txz;    # is it a .tar.xz or .txz file?
  
      ### absolute path to the archive you provided ###
      $ae->archive;
  
      ### commandline tools, if found ###
      $ae->bin_tar     # path to /bin/tar, if found
      $ae->bin_gzip    # path to /bin/gzip, if found
      $ae->bin_unzip   # path to /bin/unzip, if found
      $ae->bin_bunzip2 # path to /bin/bunzip2 if found
      $ae->bin_unlzma  # path to /bin/unlzma if found
      $ae->bin_unxz    # path to /bin/unxz if found
  
  =head1 DESCRIPTION
  
  Archive::Extract is a generic archive extraction mechanism.
  
  It allows you to extract any archive file of the type .tar, .tar.gz,
  .gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma
  without having to worry how it
  does so, or use different interfaces for each type by using either
  perl modules, or commandline tools on your system.
  
  See the C<HOW IT WORKS> section further down for details.
  
  =cut
  
  
  ### see what /bin/programs are available ###
  $PROGRAMS = {};
  CMD: for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) {
      if ( $pgm eq 'unzip' and ( ON_NETBSD or ON_FREEBSD ) ) {
        local $IPC::Cmd::INSTANCES = 1;
        ($PROGRAMS->{$pgm}) = grep { ON_NETBSD ? m!/usr/pkg/! : m!/usr/local! } can_run($pgm);
        next CMD;
      }
      if ( $pgm eq 'unzip' and ON_LINUX ) {
        # Check if 'unzip' is busybox masquerading
        local $IPC::Cmd::INSTANCES = 1;
        my $opt = ON_VMS ? '"-Z"' : '-Z';
        ($PROGRAMS->{$pgm}) = grep { scalar run(command=> [ $_, $opt, '-1' ]) } can_run($pgm);
        next CMD;
      }
      if ( $pgm eq 'tar' and ON_OPENBSD || ON_SOLARIS ) {
        # try gtar first
        next CMD if $PROGRAMS->{$pgm} = can_run('gtar');
      }
      $PROGRAMS->{$pgm} = can_run($pgm);
  }
  
  ### mapping from types to extractor methods ###
  my $Mapping = {  # binary program           # pure perl module
      is_tgz  => { bin => '_untar_bin',       pp => '_untar_at'   },
      is_tar  => { bin => '_untar_bin',       pp => '_untar_at'   },
      is_gz   => { bin => '_gunzip_bin',      pp => '_gunzip_cz'  },
      is_zip  => { bin => '_unzip_bin',       pp => '_unzip_az'   },
      is_tbz  => { bin => '_untar_bin',       pp => '_untar_at'   },
      is_bz2  => { bin => '_bunzip2_bin',     pp => '_bunzip2_bz2'},
      is_Z    => { bin => '_uncompress_bin',  pp => '_gunzip_cz'  },
      is_lzma => { bin => '_unlzma_bin',      pp => '_unlzma_cz'  },
      is_xz   => { bin => '_unxz_bin',        pp => '_unxz_cz'    },
      is_txz  => { bin => '_untar_bin',       pp => '_untar_at'   },
  };
  
  {   ### use subs so we re-generate array refs etc for the no-override flags
      ### if we don't, then we reuse the same arrayref, meaning objects store
      ### previous errors
      my $tmpl = {
          archive         => sub { { required => 1, allow => FILE_EXISTS }    },
          type            => sub { { default => '', allow => [ @Types ] }     },
          _error_msg      => sub { { no_override => 1, default => [] }        },
          _error_msg_long => sub { { no_override => 1, default => [] }        },
      };
  
      ### build accessors ###
      for my $method( keys %$tmpl,
                      qw[_extractor _gunzip_to files extract_path],
      ) {
          no strict 'refs';
          *$method = sub {
                          my $self = shift;
                          $self->{$method} = $_[0] if @_;
                          return $self->{$method};
                      }
      }
  
  =head1 METHODS
  
  =head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE])
  
  Creates a new C<Archive::Extract> object based on the archive file you
  passed it. Automatically determines the type of archive based on the
  extension, but you can override that by explicitly providing the
  C<type> argument.
  
  Valid values for C<type> are:
  
  =over 4
  
  =item tar
  
  Standard tar files, as produced by, for example, C</bin/tar>.
  Corresponds to a C<.tar> suffix.
  
  =item tgz
  
  Gzip compressed tar files, as produced by, for example C</bin/tar -z>.
  Corresponds to a C<.tgz> or C<.tar.gz> suffix.
  
  =item gz
  
  Gzip compressed file, as produced by, for example C</bin/gzip>.
  Corresponds to a C<.gz> suffix.
  
  =item Z
  
  Lempel-Ziv compressed file, as produced by, for example C</bin/compress>.
  Corresponds to a C<.Z> suffix.
  
  =item zip
  
  Zip compressed file, as produced by, for example C</bin/zip>.
  Corresponds to a C<.zip>, C<.jar> or C<.par> suffix.
  
  =item bz2
  
  Bzip2 compressed file, as produced by, for example, C</bin/bzip2>.
  Corresponds to a C<.bz2> suffix.
  
  =item tbz
  
  Bzip2 compressed tar file, as produced by, for example C</bin/tar -j>.
  Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
  
  =item lzma
  
  Lzma compressed file, as produced by C</bin/lzma>.
  Corresponds to a C<.lzma> suffix.
  
  =item xz
  
  Xz compressed file, as produced by C</bin/xz>.
  Corresponds to a C<.xz> suffix.
  
  =item txz
  
  Xz compressed tar file, as produced by, for example C</bin/tar -J>.
  Corresponds to a C<.txz> or C<.tar.xz> suffix.
  
  =back
  
  Returns a C<Archive::Extract> object on success, or false on failure.
  
  =cut
  
      ### constructor ###
      sub new {
          my $class   = shift;
          my %hash    = @_;
  
          ### see above why we use subs here and generate the template;
          ### it's basically to not re-use arrayrefs
          my %utmpl   = map { $_ => $tmpl->{$_}->() } keys %$tmpl;
  
          my $parsed = check( \%utmpl, \%hash ) or return;
  
          ### make sure we have an absolute path ###
          my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} );
  
          ### figure out the type, if it wasn't already specified ###
          unless ( $parsed->{type} ) {
              $parsed->{type} =
                  $ar =~ /.+?\.(?:tar\.gz|tgz)$/i         ? TGZ   :
                  $ar =~ /.+?\.gz$/i                      ? GZ    :
                  $ar =~ /.+?\.tar$/i                     ? TAR   :
                  $ar =~ /.+?\.(zip|jar|ear|war|par)$/i   ? ZIP   :
                  $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i     ? TBZ   :
                  $ar =~ /.+?\.bz2$/i                     ? BZ2   :
                  $ar =~ /.+?\.Z$/                        ? Z     :
                  $ar =~ /.+?\.lzma$/                     ? LZMA  :
                  $ar =~ /.+?\.(?:txz|tar\.xz)$/i         ? TXZ   :
                  $ar =~ /.+?\.xz$/                       ? XZ    :
                  '';
  
          }
  
          bless $parsed, $class;
  
          ### don't know what type of file it is
          ### XXX this *has* to be an object call, not a package call
          return $parsed->_error(loc("Cannot determine file type for '%1'",
                                  $parsed->{archive} )) unless $parsed->{type};
          return $parsed;
      }
  }
  
  =head2 $ae->extract( [to => '/output/path'] )
  
  Extracts the archive represented by the C<Archive::Extract> object to
  the path of your choice as specified by the C<to> argument. Defaults to
  C<cwd()>.
  
  Since C<.gz> files never hold a directory, but only a single file; if
  the C<to> argument is an existing directory, the file is extracted
  there, with its C<.gz> suffix stripped.
  If the C<to> argument is not an existing directory, the C<to> argument
  is understood to be a filename, if the archive type is C<gz>.
  In the case that you did not specify a C<to> argument, the output
  file will be the name of the archive file, stripped from its C<.gz>
  suffix, in the current working directory.
  
  C<extract> will try a pure perl solution first, and then fall back to
  commandline tools if they are available. See the C<GLOBAL VARIABLES>
  section below on how to alter this behaviour.
  
  It will return true on success, and false on failure.
  
  On success, it will also set the follow attributes in the object:
  
  =over 4
  
  =item $ae->extract_path
  
  This is the directory that the files where extracted to.
  
  =item $ae->files
  
  This is an array ref with the paths of all the files in the archive,
  relative to the C<to> argument you specified.
  To get the full path to an extracted file, you would use:
  
      File::Spec->catfile( $to, $ae->files->[0] );
  
  Note that all files from a tar archive will be in unix format, as per
  the tar specification.
  
  =back
  
  =cut
  
  sub extract {
      my $self = shift;
      my %hash = @_;
  
      ### reset error messages
      $self->_error_msg( [] );
      $self->_error_msg_long( [] );
  
      my $to;
      my $tmpl = {
          to  => { default => '.', store => \$to }
      };
  
      check( $tmpl, \%hash ) or return;
  
      ### so 'to' could be a file or a dir, depending on whether it's a .gz
      ### file, or basically anything else.
      ### so, check that, then act accordingly.
      ### set an accessor specifically so _gunzip can know what file to extract
      ### to.
      my $dir;
      {   ### a foo.gz file
          if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) {
  
              my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i;
  
              ### to is a dir?
              if ( -d $to ) {
                  $dir = $to;
                  $self->_gunzip_to( basename($cp) );
  
              ### then it's a filename
              } else {
                  $dir = dirname($to);
                  $self->_gunzip_to( basename($to) );
              }
  
          ### not a foo.gz file
          } else {
              $dir = $to;
          }
      }
  
      ### make the dir if it doesn't exist ###
      unless( -d $dir ) {
          eval { mkpath( $dir ) };
  
          return $self->_error(loc("Could not create path '%1': %2", $dir, $@))
              if $@;
      }
  
      ### get the current dir, to restore later ###
      my $cwd = cwd();
  
      my $ok = 1;
      EXTRACT: {
  
          ### chdir to the target dir ###
          unless( chdir $dir ) {
              $self->_error(loc("Could not chdir to '%1': %2", $dir, $!));
              $ok = 0; last EXTRACT;
          }
  
          ### set files to an empty array ref, so there's always an array
          ### ref IN the accessor, to avoid errors like:
          ### Can't use an undefined value as an ARRAY reference at
          ### ../lib/Archive/Extract.pm line 742. (rt #19815)
          $self->files( [] );
  
          ### find out the dispatch methods needed for this type of
          ### archive. Do a $self->is_XXX to figure out the type, then
          ### get the hashref with bin + pure perl dispatchers.
          my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping;
  
          ### add pure perl extractor if allowed & add bin extractor if allowed
          my @methods;
          push @methods, $map->{'pp'}  if $_ALLOW_PURE_PERL;
          push @methods, $map->{'bin'} if $_ALLOW_BIN;
  
          ### reverse it if we prefer bin extractors
          @methods = reverse @methods if $PREFER_BIN;
  
          my($na, $fail);
          for my $method (@methods) {
              $self->debug( "# Extracting with ->$method\n" );
  
              my $rv = $self->$method;
  
              ### a positive extraction
              if( $rv and $rv ne METHOD_NA ) {
                  $self->debug( "# Extraction succeeded\n" );
                  $self->_extractor($method);
                  last;
  
              ### method is not available
              } elsif ( $rv and $rv eq METHOD_NA ) {
                  $self->debug( "# Extraction method not available\n" );
                  $na++;
              } else {
                  $self->debug( "# Extraction method failed\n" );
                  $fail++;
              }
          }
  
          ### warn something went wrong if we didn't get an extractor
          unless( $self->_extractor ) {
              my $diag = $fail ? loc("Extract failed due to errors") :
                         $na   ? loc("Extract failed; no extractors available") :
                         '';
  
              $self->_error($diag);
              $ok = 0;
          }
      }
  
      ### and chdir back ###
      unless( chdir $cwd ) {
          $self->_error(loc("Could not chdir back to start dir '%1': %2'",
                              $cwd, $!));
      }
  
      return $ok;
  }
  
  =pod
  
  =head1 ACCESSORS
  
  =head2 $ae->error([BOOL])
  
  Returns the last encountered error as string.
  Pass it a true value to get the C<Carp::longmess()> output instead.
  
  =head2 $ae->extract_path
  
  This is the directory the archive got extracted to.
  See C<extract()> for details.
  
  =head2 $ae->files
  
  This is an array ref holding all the paths from the archive.
  See C<extract()> for details.
  
  =head2 $ae->archive
  
  This is the full path to the archive file represented by this
  C<Archive::Extract> object.
  
  =head2 $ae->type
  
  This is the type of archive represented by this C<Archive::Extract>
  object. See accessors below for an easier way to use this.
  See the C<new()> method for details.
  
  =head2 $ae->types
  
  Returns a list of all known C<types> for C<Archive::Extract>'s
  C<new> method.
  
  =cut
  
  sub types { return @Types }
  
  =head2 $ae->is_tgz
  
  Returns true if the file is of type C<.tar.gz>.
  See the C<new()> method for details.
  
  =head2 $ae->is_tar
  
  Returns true if the file is of type C<.tar>.
  See the C<new()> method for details.
  
  =head2 $ae->is_gz
  
  Returns true if the file is of type C<.gz>.
  See the C<new()> method for details.
  
  =head2 $ae->is_Z
  
  Returns true if the file is of type C<.Z>.
  See the C<new()> method for details.
  
  =head2 $ae->is_zip
  
  Returns true if the file is of type C<.zip>.
  See the C<new()> method for details.
  
  =head2 $ae->is_lzma
  
  Returns true if the file is of type C<.lzma>.
  See the C<new()> method for details.
  
  =head2 $ae->is_xz
  
  Returns true if the file is of type C<.xz>.
  See the C<new()> method for details.
  
  =cut
  
  ### quick check methods ###
  sub is_tgz  { return $_[0]->type eq TGZ }
  sub is_tar  { return $_[0]->type eq TAR }
  sub is_gz   { return $_[0]->type eq GZ  }
  sub is_zip  { return $_[0]->type eq ZIP }
  sub is_tbz  { return $_[0]->type eq TBZ }
  sub is_bz2  { return $_[0]->type eq BZ2 }
  sub is_Z    { return $_[0]->type eq Z   }
  sub is_lzma { return $_[0]->type eq LZMA }
  sub is_xz   { return $_[0]->type eq XZ   }
  sub is_txz  { return $_[0]->type eq TXZ }
  
  =pod
  
  =head2 $ae->bin_tar
  
  Returns the full path to your tar binary, if found.
  
  =head2 $ae->bin_gzip
  
  Returns the full path to your gzip binary, if found
  
  =head2 $ae->bin_unzip
  
  Returns the full path to your unzip binary, if found
  
  =head2 $ae->bin_unlzma
  
  Returns the full path to your unlzma binary, if found
  
  =head2 $ae->bin_unxz
  
  Returns the full path to your unxz binary, if found
  
  =cut
  
  ### paths to commandline tools ###
  sub bin_gzip        { return $PROGRAMS->{'gzip'}    if $PROGRAMS->{'gzip'}  }
  sub bin_unzip       { return $PROGRAMS->{'unzip'}   if $PROGRAMS->{'unzip'} }
  sub bin_tar         { return $PROGRAMS->{'tar'}     if $PROGRAMS->{'tar'}   }
  sub bin_bunzip2     { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
  sub bin_uncompress  { return $PROGRAMS->{'uncompress'}
                                                   if $PROGRAMS->{'uncompress'} }
  sub bin_unlzma      { return $PROGRAMS->{'unlzma'}  if $PROGRAMS->{'unlzma'} }
  sub bin_unxz        { return $PROGRAMS->{'unxz'}    if $PROGRAMS->{'unxz'} }
  
  =head2 $bool = $ae->have_old_bunzip2
  
  Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
  require all archive names to end in C<.bz2> or it will not extract
  them. This method checks if you have a recent version of C<bunzip2>
  that allows any extension, or an older one that doesn't.
  
  =cut
  
  sub have_old_bunzip2 {
      my $self = shift;
  
      ### no bunzip2? no old bunzip2 either :)
      return unless $self->bin_bunzip2;
  
      ### if we can't run this, we can't be sure if it's too old or not
      ### XXX stupid stupid stupid bunzip2 doesn't understand --version
      ### is not a request to extract data:
      ### $ bunzip2 --version
      ### bzip2, a block-sorting file compressor.  Version 1.0.2, 30-Dec-2001.
      ### [...]
      ### bunzip2: I won't read compressed data from a terminal.
      ### bunzip2: For help, type: `bunzip2 --help'.
      ### $ echo $?
      ### 1
      ### HATEFUL!
  
      ### double hateful: bunzip2 --version also hangs if input is a pipe
      ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH]
      ### So, we have to provide *another* argument which is a fake filename,
      ### just so it wont try to read from stdin to print its version..
      ### *sigh*
      ### Even if the file exists, it won't clobber or change it.
      my $buffer;
      scalar run(
           command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
           verbose => 0,
           buffer  => \$buffer
      );
  
      ### no output
      return unless $buffer;
  
      my ($version) = $buffer =~ /version \s+ (\d+)/ix;
  
      return 1 if $version < 1;
      return;
  }
  
  #################################
  #
  # Untar code
  #
  #################################
  
  ### annoying issue with (gnu) tar on win32, as illustrated by this
  ### bug: https://rt.cpan.org/Ticket/Display.html?id=40138
  ### which shows that (gnu) tar will interpret a file name with a :
  ### in it as a remote file name, so C:\tmp\foo.txt is interpreted
  ### as a remote shell, and the extract fails.
  {   my @ExtraTarFlags;
      if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) {
  
          ### if this is gnu tar we are running, we need to use --force-local
          push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
      }
  
  
      ### use /bin/tar to extract ###
      sub _untar_bin {
          my $self = shift;
  
          ### check for /bin/tar ###
          ### check for /bin/gzip if we need it ###
          ### if any of the binaries are not available, return NA
          {   my $diag =  !$self->bin_tar ?
                              loc("No '%1' program found", '/bin/tar') :
                          $self->is_tgz && !$self->bin_gzip ?
                              loc("No '%1' program found", '/bin/gzip') :
                          $self->is_tbz && !$self->bin_bunzip2 ?
                              loc("No '%1' program found", '/bin/bunzip2') :
                          $self->is_txz && !$self->bin_unxz ?
                              loc("No '%1' program found", '/bin/unxz') :
                          '';
  
              if( $diag ) {
                  $self->_error( $diag );
                  return METHOD_NA;
              }
          }
  
          ### XXX figure out how to make IPC::Run do this in one call --
          ### currently i don't know how to get output of a command after a pipe
          ### trapped in a scalar. Mailed barries about this 5th of june 2004.
  
          ### see what command we should run, based on whether
          ### it's a .tgz or .tar
  
          ### GNU tar can't handled VMS filespecs, but VMSTAR can handle Unix filespecs.
          my $archive = $self->archive;
          $archive = VMS::Filespec::unixify($archive) if ON_VMS;
  
          ### XXX solaris tar and bsdtar are having different outputs
          ### depending whether you run with -x or -t
          ### compensate for this insanity by running -t first, then -x
          {    my $cmd =
                  $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
                                   $self->bin_tar, '-tf', '-'] :
                  $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
                                   $self->bin_tar, '-tf', '-'] :
                  $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
                                   $self->bin_tar, '-tf', '-'] :
                  [$self->bin_tar, @ExtraTarFlags, '-tf', $archive];
  
              ### run the command
              ### newer versions of 'tar' (1.21 and up) now print record size
              ### to STDERR as well if v OR t is given (used to be both). This
              ### is a 'feature' according to the changelog, so we must now only
              ### inspect STDOUT, otherwise, failures like these occur:
              ### http://www.cpantesters.org/cpan/report/3230366
              my $buffer  = '';
              my @out     = run(  command => $cmd,
                                  buffer  => \$buffer,
                                  verbose => $DEBUG );
  
              ### command was unsuccessful
              unless( $out[0] ) {
                  return $self->_error(loc(
                                  "Error listing contents of archive '%1': %2",
                                  $archive, $buffer ));
              }
  
              ### no buffers available?
              if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
                  $self->_error( $self->_no_buffer_files( $archive ) );
  
              } else {
                  ### if we're on solaris we /might/ be using /bin/tar, which has
                  ### a weird output format... we might also be using
                  ### /usr/local/bin/tar, which is gnu tar, which is perfectly
                  ### fine... so we have to do some guessing here =/
                  my @files = map { chomp;
                                !ON_SOLARIS ? $_
                                            : (m|^ x \s+  # 'xtract' -- sigh
                                                  (.+?),  # the actual file name
                                                  \s+ [\d,.]+ \s bytes,
                                                  \s+ [\d,.]+ \s tape \s blocks
                                              |x ? $1 : $_);
  
                          ### only STDOUT, see above. Sometimes, extra whitespace
                          ### is present, so make sure we only pick lines with
                          ### a length
                          } grep { length } map { split $/, $_ } join '', @{$out[3]};
  
                  ### store the files that are in the archive ###
                  $self->files(\@files);
              }
          }
  
          ### now actually extract it ###
          {   my $cmd =
                  $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
                                   $self->bin_tar, '-xf', '-'] :
                  $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
                                   $self->bin_tar, '-xf', '-'] :
                  $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
                                   $self->bin_tar, '-xf', '-'] :
                  [$self->bin_tar, @ExtraTarFlags, '-xf', $archive];
  
              my $buffer = '';
              unless( scalar run( command => $cmd,
                                  buffer  => \$buffer,
                                  verbose => $DEBUG )
              ) {
                  return $self->_error(loc("Error extracting archive '%1': %2",
                                  $archive, $buffer ));
              }
  
              ### we might not have them, due to lack of buffers
              if( $self->files ) {
                  ### now that we've extracted, figure out where we extracted to
                  my $dir = $self->__get_extract_dir( $self->files );
  
                  ### store the extraction dir ###
                  $self->extract_path( $dir );
              }
          }
  
          ### we got here, no error happened
          return 1;
      }
  }
  
  
  ### use archive::tar to extract ###
  sub _untar_at {
      my $self = shift;
  
      ### Loading Archive::Tar is going to set it to 1, so make it local
      ### within this block, starting with its initial value. Whatever
      ### Achive::Tar does will be undone when we return.
      ###
      ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN
      ### so users don't have to even think about this variable. If they
      ### do, they still get their set value outside of this call.
      local $Archive::Tar::WARN = $Archive::Tar::WARN;
  
      ### we definitely need Archive::Tar, so load that first
      {   my $use_list = { 'Archive::Tar' => '0.0' };
  
          unless( can_load( modules => $use_list ) ) {
  
              $self->_error(loc("You do not have '%1' installed - " .
                                "Please install it as soon as possible.",
                                'Archive::Tar'));
  
              return METHOD_NA;
          }
      }
  
      ### we might pass it a filehandle if it's a .tbz file..
      my $fh_to_read = $self->archive;
  
      ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
      ### if A::T's version is 0.99 or higher
      if( $self->is_tgz ) {
          my $use_list = { 'Compress::Zlib' => '0.0' };
             $use_list->{ 'IO::Zlib' } = '0.0'
                  if $Archive::Tar::VERSION >= '0.99';
  
          unless( can_load( modules => $use_list ) ) {
              my $which = join '/', sort keys %$use_list;
  
              $self->_error(loc(
                  "You do not have '%1' installed - Please ".
                  "install it as soon as possible.", $which)
              );
  
              return METHOD_NA;
          }
  
      } elsif ( $self->is_tbz ) {
          my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
          unless( can_load( modules => $use_list ) ) {
              $self->_error(loc(
                  "You do not have '%1' installed - Please " .
                  "install it as soon as possible.",
                  'IO::Uncompress::Bunzip2')
              );
  
              return METHOD_NA;
          }
  
          my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
              return $self->_error(loc("Unable to open '%1': %2",
                              $self->archive,
                              $IO::Uncompress::Bunzip2::Bunzip2Error));
  
          $fh_to_read = $bz;
      } elsif ( $self->is_txz ) {
          my $use_list = { 'IO::Uncompress::UnXz' => '0.0' };
          unless( can_load( modules => $use_list ) ) {
              $self->_error(loc(
                  "You do not have '%1' installed - Please " .
                  "install it as soon as possible.",
                  'IO::Uncompress::UnXz')
              );
  
              return METHOD_NA;
          }
  
          my $xz = IO::Uncompress::UnXz->new( $self->archive ) or
              return $self->_error(loc("Unable to open '%1': %2",
                              $self->archive,
                              $IO::Uncompress::UnXz::UnXzError));
  
          $fh_to_read = $xz;
      }
  
      my @files;
      {
          ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
          ### localized $Archive::Tar::WARN already.
          $Archive::Tar::WARN = $Archive::Extract::WARN;
  
          ### only tell it it's compressed if it's a .tgz, as we give it a file
          ### handle if it's a .tbz
          my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) );
  
          ### for version of Archive::Tar > 1.04
          local $Archive::Tar::CHOWN = 0;
  
          ### use the iterator if we can. it's a feature of A::T 1.40 and up
          if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) {
  
              my $next;
              unless ( $next = Archive::Tar->iter( @read ) ) {
                  return $self->_error(loc(
                              "Unable to read '%1': %2", $self->archive,
                              $Archive::Tar::error));
              }
  
              while ( my $file = $next->() ) {
                  push @files, $file->full_path;
  
                  $file->extract or return $self->_error(loc(
                          "Unable to read '%1': %2",
                          $self->archive,
                          $Archive::Tar::error));
              }
  
          ### older version, read the archive into memory
          } else {
  
              my $tar = Archive::Tar->new();
  
              unless( $tar->read( @read ) ) {
                  return $self->_error(loc("Unable to read '%1': %2",
                              $self->archive, $Archive::Tar::error));
              }
  
              ### workaround to prevent Archive::Tar from setting uid, which
              ### is a potential security hole. -autrijus
              ### have to do it here, since A::T needs to be /loaded/ first ###
              {   no strict 'refs'; local $^W;
  
                  ### older versions of archive::tar <= 0.23
                  *Archive::Tar::chown = sub {};
              }
  
              {   local $^W;  # quell 'splice() offset past end of array' warnings
                              # on older versions of A::T
  
                  ### older archive::tar always returns $self, return value
                  ### slightly fux0r3d because of it.
                  $tar->extract or return $self->_error(loc(
                          "Unable to extract '%1': %2",
                          $self->archive, $Archive::Tar::error ));
              }
  
              @files = $tar->list_files;
          }
      }
  
      my $dir = $self->__get_extract_dir( \@files );
  
      ### store the files that are in the archive ###
      $self->files(\@files);
  
      ### store the extraction dir ###
      $self->extract_path( $dir );
  
      ### check if the dir actually appeared ###
      return 1 if -d $self->extract_path;
  
      ### no dir, we failed ###
      return $self->_error(loc("Unable to extract '%1': %2",
                                  $self->archive, $Archive::Tar::error ));
  }
  
  #################################
  #
  # Gunzip code
  #
  #################################
  
  sub _gunzip_bin {
      my $self = shift;
  
      ### check for /bin/gzip -- we need it ###
      unless( $self->bin_gzip ) {
          $self->_error(loc("No '%1' program found", '/bin/gzip'));
          return METHOD_NA;
      }
  
      my $fh = FileHandle->new('>'. $self->_gunzip_to) or
          return $self->_error(loc("Could not open '%1' for writing: %2",
                              $self->_gunzip_to, $! ));
  
      my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];
  
      my $buffer;
      unless( scalar run( command => $cmd,
                          verbose => $DEBUG,
                          buffer  => \$buffer )
      ) {
          return $self->_error(loc("Unable to gunzip '%1': %2",
                                      $self->archive, $buffer));
      }
  
      ### no buffers available?
      if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
          $self->_error( $self->_no_buffer_content( $self->archive ) );
      }
  
      $self->_print($fh, $buffer) if defined $buffer;
  
      close $fh;
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  sub _gunzip_cz {
      my $self = shift;
  
      my $use_list = { 'Compress::Zlib' => '0.0' };
      unless( can_load( modules => $use_list ) ) {
          $self->_error(loc("You do not have '%1' installed - Please " .
                      "install it as soon as possible.", 'Compress::Zlib'));
          return METHOD_NA;
      }
  
      my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
                  return $self->_error(loc("Unable to open '%1': %2",
                              $self->archive, $Compress::Zlib::gzerrno));
  
      my $fh = FileHandle->new('>'. $self->_gunzip_to) or
          return $self->_error(loc("Could not open '%1' for writing: %2",
                              $self->_gunzip_to, $! ));
  
      my $buffer;
      $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0;
      $fh->close;
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  #################################
  #
  # Uncompress code
  #
  #################################
  
  sub _uncompress_bin {
      my $self = shift;
  
      ### check for /bin/gzip -- we need it ###
      unless( $self->bin_uncompress ) {
          $self->_error(loc("No '%1' program found", '/bin/uncompress'));
          return METHOD_NA;
      }
  
      my $fh = FileHandle->new('>'. $self->_gunzip_to) or
          return $self->_error(loc("Could not open '%1' for writing: %2",
                              $self->_gunzip_to, $! ));
  
      my $cmd = [ $self->bin_uncompress, '-c', $self->archive ];
  
      my $buffer;
      unless( scalar run( command => $cmd,
                          verbose => $DEBUG,
                          buffer  => \$buffer )
      ) {
          return $self->_error(loc("Unable to uncompress '%1': %2",
                                      $self->archive, $buffer));
      }
  
      ### no buffers available?
      if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
          $self->_error( $self->_no_buffer_content( $self->archive ) );
      }
  
      $self->_print($fh, $buffer) if defined $buffer;
  
      close $fh;
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  
  #################################
  #
  # Unzip code
  #
  #################################
  
  
  sub _unzip_bin {
      my $self = shift;
  
      ### check for /bin/gzip if we need it ###
      unless( $self->bin_unzip ) {
          $self->_error(loc("No '%1' program found", '/bin/unzip'));
          return METHOD_NA;
      }
  
      ### first, get the files.. it must be 2 different commands with 'unzip' :(
      {   ### on VMS, capital letter options have to be quoted. This is
          ### reported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
          ### Subject: [patch@31735]Archive Extract fix on VMS.
          my $opt = ON_VMS ? '"-Z"' : '-Z';
          my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ];
  
          my $buffer = '';
          unless( scalar run( command => $cmd,
                              verbose => $DEBUG,
                              buffer  => \$buffer )
          ) {
              return $self->_error(loc("Unable to unzip '%1': %2",
                                          $self->archive, $buffer));
          }
  
          ### no buffers available?
          if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
              $self->_error( $self->_no_buffer_files( $self->archive ) );
  
          } else {
              ### Annoyingly, pesky MSWin32 can either have 'native' tools
              ### which have \r\n line endings or Cygwin-based tools which
              ### have \n line endings. Jan Dubois suggested using this fix
              local $/ = ON_WIN32 ? qr/\r?\n/ : "\n";
              $self->files( [split $/, $buffer] );
          }
      }
  
      ### now, extract the archive ###
      {   my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ];
  
          my $buffer;
          unless( scalar run( command => $cmd,
                              verbose => $DEBUG,
                              buffer  => \$buffer )
          ) {
              return $self->_error(loc("Unable to unzip '%1': %2",
                                          $self->archive, $buffer));
          }
  
          if( scalar @{$self->files} ) {
              my $files   = $self->files;
              my $dir     = $self->__get_extract_dir( $files );
  
              $self->extract_path( $dir );
          }
      }
  
      return 1;
  }
  
  sub _unzip_az {
      my $self = shift;
  
      my $use_list = { 'Archive::Zip' => '0.0' };
      unless( can_load( modules => $use_list ) ) {
          $self->_error(loc("You do not have '%1' installed - Please " .
                        "install it as soon as possible.", 'Archive::Zip'));
          return METHOD_NA;
      }
  
      my $zip = Archive::Zip->new();
  
      unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) {
          return $self->_error(loc("Unable to read '%1'", $self->archive));
      }
  
      my @files;
  
  
      ### Address: #43278: Explicitly tell Archive::Zip where to put the files:
      ### "In my BackPAN indexing, Archive::Zip was extracting things
      ### in my script's directory instead of the current working directory.
      ### I traced this back through Archive::Zip::_asLocalName which
      ### eventually calls File::Spec::Win32::rel2abs which on Windows might
      ### call Cwd::getdcwd. getdcwd returns the wrong directory in my
      ### case, even though I think I'm on the same drive.
      ###
      ### To fix this, I pass the optional second argument to
      ### extractMember using the cwd from Archive::Extract." --bdfoy
  
      ## store cwd() before looping; calls to cwd() can be expensive, and
      ### it won't change during the loop
      my $extract_dir = cwd();
  
      ### have to extract every member individually ###
      for my $member ($zip->members) {
          push @files, $member->{fileName};
  
          ### file to extract to, to avoid the above problem
          my $to = File::Spec->catfile( $extract_dir, $member->{fileName} );
  
          unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) {
              return $self->_error(loc("Extraction of '%1' from '%2' failed",
                          $member->{fileName}, $self->archive ));
          }
      }
  
      my $dir = $self->__get_extract_dir( \@files );
  
      ### set what files where extract, and where they went ###
      $self->files( \@files );
      $self->extract_path( File::Spec->rel2abs($dir) );
  
      return 1;
  }
  
  sub __get_extract_dir {
      my $self    = shift;
      my $files   = shift || [];
  
      return unless scalar @$files;
  
      my($dir1, $dir2);
      for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
          my($dir,$pos) = @$aref;
  
          ### add a catdir(), so that any trailing slashes get
          ### take care of (removed)
          ### also, a catdir() normalises './dir/foo' to 'dir/foo';
          ### which was the problem in bug #23999
          my $res = -d $files->[$pos]
                      ? File::Spec->catdir( $files->[$pos], '' )
                      : File::Spec->catdir( dirname( $files->[$pos] ) );
  
          $$dir = $res;
      }
  
      ### if the first and last dir don't match, make sure the
      ### dirname is not set wrongly
      my $dir;
  
      ### dirs are the same, so we know for sure what the extract dir is
      if( $dir1 eq $dir2 ) {
          $dir = $dir1;
  
      ### dirs are different.. do they share the base dir?
      ### if so, use that, if not, fall back to '.'
      } else {
          my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
          my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
  
          $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
      }
  
      return File::Spec->rel2abs( $dir );
  }
  
  #################################
  #
  # Bunzip2 code
  #
  #################################
  
  sub _bunzip2_bin {
      my $self = shift;
  
      ### check for /bin/gzip -- we need it ###
      unless( $self->bin_bunzip2 ) {
          $self->_error(loc("No '%1' program found", '/bin/bunzip2'));
          return METHOD_NA;
      }
  
      my $fh = FileHandle->new('>'. $self->_gunzip_to) or
          return $self->_error(loc("Could not open '%1' for writing: %2",
                              $self->_gunzip_to, $! ));
  
      ### guard against broken bunzip2. See ->have_old_bunzip2()
      ### for details
      if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) {
          return $self->_error(loc("Your bunzip2 version is too old and ".
                                   "can only extract files ending in '%1'",
                                   '.bz2'));
      }
  
      my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ];
  
      my $buffer;
      unless( scalar run( command => $cmd,
                          verbose => $DEBUG,
                          buffer  => \$buffer )
      ) {
          return $self->_error(loc("Unable to bunzip2 '%1': %2",
                                      $self->archive, $buffer));
      }
  
      ### no buffers available?
      if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
          $self->_error( $self->_no_buffer_content( $self->archive ) );
      }
  
      $self->_print($fh, $buffer) if defined $buffer;
  
      close $fh;
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  ### using cz2, the compact versions... this we use mainly in archive::tar
  ### extractor..
  # sub _bunzip2_cz1 {
  #     my $self = shift;
  #
  #     my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
  #     unless( can_load( modules => $use_list ) ) {
  #         return $self->_error(loc("You do not have '%1' installed - Please " .
  #                         "install it as soon as possible.",
  #                         'IO::Uncompress::Bunzip2'));
  #     }
  #
  #     my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
  #                 return $self->_error(loc("Unable to open '%1': %2",
  #                             $self->archive,
  #                             $IO::Uncompress::Bunzip2::Bunzip2Error));
  #
  #     my $fh = FileHandle->new('>'. $self->_gunzip_to) or
  #         return $self->_error(loc("Could not open '%1' for writing: %2",
  #                             $self->_gunzip_to, $! ));
  #
  #     my $buffer;
  #     $fh->print($buffer) while $bz->read($buffer) > 0;
  #     $fh->close;
  #
  #     ### set what files where extract, and where they went ###
  #     $self->files( [$self->_gunzip_to] );
  #     $self->extract_path( File::Spec->rel2abs(cwd()) );
  #
  #     return 1;
  # }
  
  sub _bunzip2_bz2 {
      my $self = shift;
  
      my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
      unless( can_load( modules => $use_list ) ) {
          $self->_error(loc("You do not have '%1' installed - Please " .
                            "install it as soon as possible.",
                            'IO::Uncompress::Bunzip2'));
          return METHOD_NA;
      }
  
      IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to)
          or return $self->_error(loc("Unable to uncompress '%1': %2",
                              $self->archive,
                              $IO::Uncompress::Bunzip2::Bunzip2Error));
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  #################################
  #
  # UnXz code
  #
  #################################
  
  sub _unxz_bin {
      my $self = shift;
  
      ### check for /bin/unxz -- we need it ###
      unless( $self->bin_unxz ) {
          $self->_error(loc("No '%1' program found", '/bin/unxz'));
          return METHOD_NA;
      }
  
      my $fh = FileHandle->new('>'. $self->_gunzip_to) or
          return $self->_error(loc("Could not open '%1' for writing: %2",
                              $self->_gunzip_to, $! ));
  
      my $cmd = [ $self->bin_unxz, '-cdf', $self->archive ];
  
      my $buffer;
      unless( scalar run( command => $cmd,
                          verbose => $DEBUG,
                          buffer  => \$buffer )
      ) {
          return $self->_error(loc("Unable to unxz '%1': %2",
                                      $self->archive, $buffer));
      }
  
      ### no buffers available?
      if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
          $self->_error( $self->_no_buffer_content( $self->archive ) );
      }
  
      $self->_print($fh, $buffer) if defined $buffer;
  
      close $fh;
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  sub _unxz_cz {
      my $self = shift;
  
      my $use_list = { 'IO::Uncompress::UnXz' => '0.0' };
      unless( can_load( modules => $use_list ) ) {
          $self->_error(loc("You do not have '%1' installed - Please " .
                            "install it as soon as possible.",
                            'IO::Uncompress::UnXz'));
          return METHOD_NA;
      }
  
      IO::Uncompress::UnXz::unxz($self->archive => $self->_gunzip_to)
          or return $self->_error(loc("Unable to uncompress '%1': %2",
                              $self->archive,
                              $IO::Uncompress::UnXz::UnXzError));
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  
  #################################
  #
  # unlzma code
  #
  #################################
  
  sub _unlzma_bin {
      my $self = shift;
  
      ### check for /bin/unlzma -- we need it ###
      unless( $self->bin_unlzma ) {
          $self->_error(loc("No '%1' program found", '/bin/unlzma'));
          return METHOD_NA;
      }
  
      my $fh = FileHandle->new('>'. $self->_gunzip_to) or
          return $self->_error(loc("Could not open '%1' for writing: %2",
                              $self->_gunzip_to, $! ));
  
      my $cmd = [ $self->bin_unlzma, '-c', $self->archive ];
  
      my $buffer;
      unless( scalar run( command => $cmd,
                          verbose => $DEBUG,
                          buffer  => \$buffer )
      ) {
          return $self->_error(loc("Unable to unlzma '%1': %2",
                                      $self->archive, $buffer));
      }
  
      ### no buffers available?
      if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
          $self->_error( $self->_no_buffer_content( $self->archive ) );
      }
  
      $self->_print($fh, $buffer) if defined $buffer;
  
      close $fh;
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  sub _unlzma_cz {
      my $self = shift;
  
      my $use_list1 = { 'IO::Uncompress::UnLzma' => '0.0' };
      my $use_list2 = { 'Compress::unLZMA' => '0.0' };
  
      if (can_load( modules => $use_list1 ) ) {
          IO::Uncompress::UnLzma::unlzma($self->archive => $self->_gunzip_to)
              or return $self->_error(loc("Unable to uncompress '%1': %2",
                                  $self->archive,
                                  $IO::Uncompress::UnLzma::UnLzmaError));
      }
      elsif (can_load( modules => $use_list2 ) ) {
  
          my $fh = FileHandle->new('>'. $self->_gunzip_to) or
              return $self->_error(loc("Could not open '%1' for writing: %2",
                                  $self->_gunzip_to, $! ));
  
          my $buffer;
          $buffer = Compress::unLZMA::uncompressfile( $self->archive );
          unless ( defined $buffer ) {
              return $self->_error(loc("Could not unlzma '%1': %2",
                                          $self->archive, $@));
          }
  
          $self->_print($fh, $buffer) if defined $buffer;
  
          close $fh;
      }
      else {
          $self->_error(loc("You do not have '%1' or '%2' installed - Please " .
                      "install it as soon as possible.", 'Compress::unLZMA', 'IO::Uncompress::UnLzma'));
          return METHOD_NA;
      }
  
      ### set what files where extract, and where they went ###
      $self->files( [$self->_gunzip_to] );
      $self->extract_path( File::Spec->rel2abs(cwd()) );
  
      return 1;
  }
  
  #################################
  #
  # Error code
  #
  #################################
  
  # For printing binaries that avoids interfering globals
  sub _print {
      my $self = shift;
      my $fh = shift;
  
      local( $\, $", $, ) = ( undef, ' ', '' );
      return print $fh @_;
  }
  
  sub _error {
      my $self    = shift;
      my $error   = shift;
      my $lerror  = Carp::longmess($error);
  
      push @{$self->_error_msg},      $error;
      push @{$self->_error_msg_long}, $lerror;
  
      ### set $Archive::Extract::WARN to 0 to disable printing
      ### of errors
      if( $WARN ) {
          carp $DEBUG ? $lerror : $error;
      }
  
      return;
  }
  
  sub error {
      my $self = shift;
  
      ### make sure we have a fallback aref
      my $aref = do {
          shift()
              ? $self->_error_msg_long
              : $self->_error_msg
      } || [];
  
      return join $/, @$aref;
  }
  
  =head2 debug( MESSAGE )
  
  This method outputs MESSAGE to the default filehandle if C<$DEBUG> is
  true. It's a small method, but it's here if you'd like to subclass it
  so you can so something else with any debugging output.
  
  =cut
  
  ### this is really a stub for subclassing
  sub debug {
      return unless $DEBUG;
  
      print $_[1];
  }
  
  sub _no_buffer_files {
      my $self = shift;
      my $file = shift or return;
      return loc("No buffer captured, unable to tell ".
                 "extracted files or extraction dir for '%1'", $file);
  }
  
  sub _no_buffer_content {
      my $self = shift;
      my $file = shift or return;
      return loc("No buffer captured, unable to get content for '%1'", $file);
  }
  1;
  
  =pod
  
  =head1 HOW IT WORKS
  
  C<Archive::Extract> tries first to determine what type of archive you
  are passing it, by inspecting its suffix. It does not do this by using
  Mime magic, or something related. See C<CAVEATS> below.
  
  Once it has determined the file type, it knows which extraction methods
  it can use on the archive. It will try a perl solution first, then fall
  back to a commandline tool if that fails. If that also fails, it will
  return false, indicating it was unable to extract the archive.
  See the section on C<GLOBAL VARIABLES> to see how to alter this order.
  
  =head1 CAVEATS
  
  =head2 File Extensions
  
  C<Archive::Extract> trusts on the extension of the archive to determine
  what type it is, and what extractor methods therefore can be used. If
  your archives do not have any of the extensions as described in the
  C<new()> method, you will have to specify the type explicitly, or
  C<Archive::Extract> will not be able to extract the archive for you.
  
  =head2 Supporting Very Large Files
  
  C<Archive::Extract> can use either pure perl modules or command line
  programs under the hood. Some of the pure perl modules (like
  C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
  which may not be feasible on your system. Consider setting the global
  variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
  the use of command line programs and won't consume so much memory.
  
  See the C<GLOBAL VARIABLES> section below for details.
  
  =head2 Bunzip2 support of arbitrary extensions.
  
  Older versions of C</bin/bunzip2> do not support arbitrary file
  extensions and insist on a C<.bz2> suffix. Although we do our best
  to guard against this, if you experience a bunzip2 error, it may
  be related to this. For details, please see the C<have_old_bunzip2>
  method.
  
  =head1 GLOBAL VARIABLES
  
  =head2 $Archive::Extract::DEBUG
  
  Set this variable to C<true> to have all calls to command line tools
  be printed out, including all their output.
  This also enables C<Carp::longmess> errors, instead of the regular
  C<carp> errors.
  
  Good for tracking down why things don't work with your particular
  setup.
  
  Defaults to C<false>.
  
  =head2 $Archive::Extract::WARN
  
  This variable controls whether errors encountered internally by
  C<Archive::Extract> should be C<carp>'d or not.
  
  Set to false to silence warnings. Inspect the output of the C<error()>
  method manually to see what went wrong.
  
  Defaults to C<true>.
  
  =head2 $Archive::Extract::PREFER_BIN
  
  This variables controls whether C<Archive::Extract> should prefer the
  use of perl modules, or commandline tools to extract archives.
  
  Set to C<true> to have C<Archive::Extract> prefer commandline tools.
  
  Defaults to C<false>.
  
  =head1 TODO / CAVEATS
  
  =over 4
  
  =item Mime magic support
  
  Maybe this module should use something like C<File::Type> to determine
  the type, rather than blindly trust the suffix.
  
  =item Thread safety
  
  Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before
  extraction, and a C<chdir> back again after. This is not necessarily
  thread safe. See C<rt.cpan.org> bug C<#45671> for details.
  
  =back
  
  =head1 BUG REPORTS
  
  Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.orgE<gt>.
  
  =head1 AUTHOR
  
  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
  
  =head1 COPYRIGHT
  
  This library is free software; you may redistribute and/or modify it
  under the same terms as Perl itself.
  
  =cut
  
  # Local variables:
  # c-indentation-style: bsd
  # c-basic-offset: 4
  # indent-tabs-mode: nil
  # End:
  # vim: expandtab shiftwidth=4:
  
ARCHIVE_EXTRACT

$fatpacked{"B/Hooks/EndOfScope.pm"} = <<'B_HOOKS_ENDOFSCOPE';
  package B::Hooks::EndOfScope;
  BEGIN {
    $B::Hooks::EndOfScope::AUTHORITY = 'cpan:FLORA';
  }
  {
    $B::Hooks::EndOfScope::VERSION = '0.12';
  }
  # ABSTRACT: Execute code after a scope finished compilation
  
  use strict;
  use warnings;
  
  # note - a %^H tie() fallback will probably work on 5.6 as well,
  # if you need to go that low - sane patches passing *all* tests
  # will be gladly accepted
  use 5.008001;
  
  BEGIN {
    require Module::Implementation;
    my $impl = Module::Implementation::implementation_for('B::Hooks::EndOfScope') || do {
      Module::Implementation::build_loader_sub(
        implementations => [ 'XS', 'PP' ],
        symbols => [ 'on_scope_end' ],
      )->();
      Module::Implementation::implementation_for('B::Hooks::EndOfScope');
    };
  
    *on_scope_end = $impl eq 'XS'
      ? \&B::Hooks::EndOfScope::XS::on_scope_end
      : \&B::Hooks::EndOfScope::PP::on_scope_end
    ;
  }
  
  use Sub::Exporter::Progressive -setup => {
    exports => [ 'on_scope_end' ],
    groups  => { default => ['on_scope_end'] },
  };
  
  
  1;
  
  __END__
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  B::Hooks::EndOfScope - Execute code after a scope finished compilation
  
  =head1 SYNOPSIS
  
      on_scope_end { ... };
  
  =head1 DESCRIPTION
  
  This module allows you to execute code when perl finished compiling the
  surrounding scope.
  
  =head1 FUNCTIONS
  
  =head2 on_scope_end
  
      on_scope_end { ... };
  
      on_scope_end $code;
  
  Registers C<$code> to be executed after the surrounding scope has been
  compiled.
  
  This is exported by default. See L<Sub::Exporter> on how to customize it.
  
  =head1 PURE-PERL MODE CAVEAT
  
  While L<Variable::Magic> has access to some very dark sorcery to make it
  possible to throw an exception from within a callback, the pure-perl
  implementation does not have access to these hacks. Therefore, what
  would have been a compile-time exception is instead converted to a
  warning, and your execution will continue as if the exception never
  happened.
  
  To explicitly request an XS (or PP) implementation one has two choices. Either
  to import from the desired implementation explicitly:
  
   use B::Hooks::EndOfScope::XS
     or
   use B::Hooks::EndOfScope::PP
  
  or by setting C<$ENV{B_HOOKS_ENDOFSCOPE_IMPLEMENTATION}> to either C<XS> or
  C<PP>.
  
  =head1 SEE ALSO
  
  L<Sub::Exporter>
  
  L<Variable::Magic>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Florian Ragwitz.
  
  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
  
B_HOOKS_ENDOFSCOPE

$fatpacked{"B/Hooks/EndOfScope/PP.pm"} = <<'B_HOOKS_ENDOFSCOPE_PP';
  package B::Hooks::EndOfScope::PP;
  BEGIN {
    $B::Hooks::EndOfScope::PP::AUTHORITY = 'cpan:FLORA';
  }
  {
    $B::Hooks::EndOfScope::PP::VERSION = '0.12';
  }
  # ABSTRACT: Execute code after a scope finished compilation - PP implementation
  
  use warnings;
  use strict;
  
  use Module::Runtime 'require_module';
  use constant _PERL_VERSION => "$]";
  
  BEGIN {
    if (_PERL_VERSION =~ /^5\.009/) {
      # CBA to figure out where %^H got broken and which H::U::HH is sane enough
      die "By design B::Hooks::EndOfScope does not operate in pure-perl mode on perl 5.9.X\n"
    }
    elsif (_PERL_VERSION < '5.010') {
      require_module('B::Hooks::EndOfScope::PP::HintHash');
      *on_scope_end = \&B::Hooks::EndOfScope::PP::HintHash::on_scope_end;
    }
    else {
      require_module('B::Hooks::EndOfScope::PP::FieldHash');
      *on_scope_end = \&B::Hooks::EndOfScope::PP::FieldHash::on_scope_end;
    }
  }
  
  use Sub::Exporter::Progressive -setup => {
    exports => ['on_scope_end'],
    groups  => { default => ['on_scope_end'] },
  };
  
  sub __invoke_callback {
    local $@;
    eval { $_[0]->(); 1 } or do {
      my $err = $@;
      require Carp;
      Carp::cluck( (join ' ',
        'A scope-end callback raised an exception, which can not be propagated when',
        'B::Hooks::EndOfScope operates in pure-perl mode. Your program will CONTINUE',
        'EXECUTION AS IF NOTHING HAPPENED AFTER THIS WARNING. Below is the complete',
        'exception text, followed by a stack-trace of the callback execution:',
      ) . "\n\n$err\n\r" );
  
      sleep 1 if -t *STDERR;  # maybe a bad idea...?
    };
  }
  
  
  1;
  
  __END__
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  B::Hooks::EndOfScope::PP - Execute code after a scope finished compilation - PP implementation
  
  =head1 DESCRIPTION
  
  This is the pure-perl implementation of L<B::Hooks::EndOfScope> based only on
  modules available as part of the perl core. Its leaner sibling
  L<B::Hooks::EndOfScope::XS> will be automatically preferred if all
  dependencies are available and C<$ENV{B_HOOKS_ENDOFSCOPE_IMPLEMENTATION}> is
  not set to C<'PP'>.
  
  =head1 FUNCTIONS
  
  =head2 on_scope_end
  
      on_scope_end { ... };
  
      on_scope_end $code;
  
  Registers C<$code> to be executed after the surrounding scope has been
  compiled.
  
  This is exported by default. See L<Sub::Exporter> on how to customize it.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Florian Ragwitz.
  
  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
  
B_HOOKS_ENDOFSCOPE_PP

$fatpacked{"B/Hooks/EndOfScope/PP/FieldHash.pm"} = <<'B_HOOKS_ENDOFSCOPE_PP_FIELDHASH';
  # Implementtion of a pure-perl on_scope_end for perls > 5.10
  # (relies on Hash::Util:FieldHash)
  
  package # hide from pause
    B::Hooks::EndOfScope::PP::FieldHash;
  
  use strict;
  use warnings;
  
  use warnings;
  use strict;
  
  use Tie::Hash ();
  use Hash::Util::FieldHash 'fieldhash';
  
  # Here we rely on a combination of several behaviors:
  #
  # * %^H is deallocated on scope exit, so any references to it disappear
  # * A lost weakref in a fieldhash causes the corresponding key to be deleted
  # * Deletion of a key on a tied hash triggers DELETE
  #
  # Therefore the DELETE of a tied fieldhash containing a %^H reference will
  # be the hook to fire all our callbacks.
  
  fieldhash my %hh;
  {
    package # hide from pause too
      B::Hooks::EndOfScope::PP::_TieHintHashFieldHash;
    use base 'Tie::StdHash';
    sub DELETE {
      my $ret = shift->SUPER::DELETE(@_);
      B::Hooks::EndOfScope::PP::__invoke_callback($_) for @$ret;
      $ret;
    }
  }
  
  sub on_scope_end (&) {
    $^H |= 0x020000;
  
    tie(%hh, 'B::Hooks::EndOfScope::PP::_TieHintHashFieldHash')
      unless tied %hh;
  
    push @{ $hh{\%^H} ||= [] }, shift;
  }
  
  1;
  
  __END__
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  B::Hooks::EndOfScope::PP::FieldHash
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Florian Ragwitz.
  
  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
  
B_HOOKS_ENDOFSCOPE_PP_FIELDHASH

$fatpacked{"B/Hooks/EndOfScope/PP/HintHash.pm"} = <<'B_HOOKS_ENDOFSCOPE_PP_HINTHASH';
  # Implementtion of a pure-perl on_scope_end for perl 5.8.X
  # (relies on lack of compile/runtime duality of %^H before 5.10
  # which makes guard object operation possible)
  
  package # hide from the pauses
    B::Hooks::EndOfScope::PP::HintHash;
  
  use strict;
  use warnings;
  use Scalar::Util ();
  
  # This is the original implementation, which sadly is broken
  # on perl 5.10+ within string evals
  sub on_scope_end (&) {
    $^H |= 0x020000;
  
    # localised %^H behaves funny on 5.8 - a
    # 'local %^H;'
    # is in effect the same as
    # 'local %^H = %^H;'
    # therefore make sure we use different keys so that things do not
    # fire too early due to hashkey overwrite
    push @{
      $^H{sprintf '__B_H_EOS__guardstack_0X%x', Scalar::Util::refaddr(\%^H) }
        ||= bless ([], 'B::Hooks::EndOfScope::PP::_SG_STACK')
    }, shift;
  }
  
  package # hide from the pauses
    B::Hooks::EndOfScope::PP::_SG_STACK;
  
  use warnings;
  use strict;
  
  sub DESTROY {
    B::Hooks::EndOfScope::PP::__invoke_callback($_) for @{$_[0]};
  }
  
  1;
  
  __END__
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  B::Hooks::EndOfScope::PP::HintHash
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Florian Ragwitz.
  
  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
  
B_HOOKS_ENDOFSCOPE_PP_HINTHASH

$fatpacked{"B/Hooks/EndOfScope/XS.pm"} = <<'B_HOOKS_ENDOFSCOPE_XS';
  package B::Hooks::EndOfScope::XS;
  BEGIN {
    $B::Hooks::EndOfScope::XS::AUTHORITY = 'cpan:FLORA';
  }
  {
    $B::Hooks::EndOfScope::XS::VERSION = '0.12';
  }
  # ABSTRACT: Execute code after a scope finished compilation - XS implementation
  
  use strict;
  use warnings;
  
  BEGIN {
    require Module::Runtime;
    # Adjust the Makefile.PL if changing this minimum version
    Module::Runtime::use_module('Variable::Magic', '0.48');
  }
  
  use Sub::Exporter::Progressive -setup => {
    exports => ['on_scope_end'],
    groups  => { default => ['on_scope_end'] },
  };
  
  my $wiz = Variable::Magic::wizard
    data => sub { [$_[1]] },
    free => sub { $_->() for @{ $_[1] }; () },
    # When someone localise %^H, our magic doesn't want to be copied
    # down. We want it to be around only for the scope we've initially
    # attached ourselfs to. Merely having MGf_LOCAL and a noop svt_local
    # callback achieves this. If anything wants to attach more magic of our
    # kind to a localised %^H, things will continue to just work as we'll be
    # attached with a new and empty callback list.
    local => \undef
  ;
  
  sub on_scope_end (&) {
    my $cb = shift;
  
    $^H |= 0x020000;
  
    if (my $stack = Variable::Magic::getdata %^H, $wiz) {
      push @{ $stack }, $cb;
    }
    else {
      Variable::Magic::cast %^H, $wiz, $cb;
    }
  }
  
  
  
  1;
  
  __END__
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  B::Hooks::EndOfScope::XS - Execute code after a scope finished compilation - XS implementation
  
  =head1 DESCRIPTION
  
  This is the implementation of L<B::Hooks::EndOfScope> based on
  L<Variable::Magic>, which is an XS module dependent on a compiler. It will
  always be automatically preferred if L<Variable::Magic> is available.
  
  =head1 FUNCTIONS
  
  =head2 on_scope_end
  
      on_scope_end { ... };
  
      on_scope_end $code;
  
  Registers C<$code> to be executed after the surrounding scope has been
  compiled.
  
  This is exported by default. See L<Sub::Exporter> on how to customize it.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Florian Ragwitz.
  
  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
  
B_HOOKS_ENDOFSCOPE_XS

$fatpacked{"CPAN/Perl/Releases.pm"} = <<'CPAN_PERL_RELEASES';
  package CPAN::Perl::Releases;
  {
    $CPAN::Perl::Releases::VERSION = '1.42';
  }
  
  #ABSTRACT: Mapping Perl releases on CPAN to the location of the tarballs
  
  use strict;
  use warnings;
  use vars qw[@ISA @EXPORT_OK];
  
  use Exporter;
  
  @ISA       = qw(Exporter);
  @EXPORT_OK = qw(perl_tarballs perl_versions perl_pumpkins);
  
  # Data gathered from using findlinks.pl script in this dists tools/
  # directory, run over the src/5.0 of a local CPAN mirror.
  our $cache = { };
  our $data =
  {
  "5.003_07" => { id => 'ANDYD' },
  "5.004" => { id => 'CHIPS' },
  "5.004_01" => { id => 'TIMB' },
  "5.004_02" => { id => 'TIMB' },
  "5.004_03" => { id => 'TIMB' },
  "5.004_04" => { id => 'TIMB' },
  "5.004_05" => { id => 'CHIPS' },
  "5.005" => { id => 'GSAR' },
  "5.005_01" => { id => 'GSAR' },
  "5.005_02" => { id => 'GSAR' },
  "5.005_03" => { id => 'GBARR' },
  "5.005_04" => { id => 'LBROCARD' },
  "5.6.0" => { id => 'GSAR' },
  "5.6.1-TRIAL1" => { id => 'GSAR' },
  "5.6.1-TRIAL2" => { id => 'GSAR' },
  "5.6.1-TRIAL3" => { id => 'GSAR' },
  "5.6.1" => { id => 'GSAR' },
  "5.6.2" => { id => 'RGARCIA' },
  "5.7.0" => { id => 'JHI' },
  "5.7.1" => { id => 'JHI' },
  "5.7.2" => { id => 'JHI' },
  "5.7.3" => { id => 'JHI' },
  "5.8.0" => { id => 'JHI' },
  "5.8.1" => { id => 'JHI' },
  "5.8.2" => { id => 'NWCLARK' },
  "5.8.3" => { id => 'NWCLARK' },
  "5.8.4" => { id => 'NWCLARK' },
  "5.8.5" => { id => 'NWCLARK' },
  "5.8.6" => { id => 'NWCLARK' },
  "5.8.7" => { id => 'NWCLARK' },
  "5.8.8" => { id => 'NWCLARK' },
  "5.8.9" => { id => 'NWCLARK' },
  "5.9.0" => { id => 'HVDS' },
  "5.9.1" => { id => 'RGARCIA' },
  "5.9.2" => { id => 'RGARCIA' },
  "5.9.3" => { id => 'RGARCIA' },
  "5.9.4" => { id => 'RGARCIA' },
  "5.9.5" => { id => 'RGARCIA' },
  "5.10.0" => { id => 'RGARCIA' },
  "5.10.1" => { id => 'DAPM' },
  "5.11.0" => { id => 'JESSE' },
  "5.11.1" => { id => 'JESSE' },
  "5.11.2" => { id => 'LBROCARD' },
  "5.11.3" => { id => 'JESSE' },
  "5.11.4" => { id => 'RJBS' },
  "5.11.5" => { id => 'SHAY' },
  "5.12.0" => { id => 'JESSE' },
  "5.12.1" => { id => 'JESSE' },
  "5.12.2" => { id => 'JESSE' },
  "5.12.3" => { id => 'RJBS' },
  "5.12.4" => { id => 'LBROCARD' },
  "5.12.5" => { id => 'DOM' },
  "5.13.0" => { id => 'LBROCARD' },
  "5.13.1" => { id => 'RJBS' },
  "5.13.2" => { id => 'MSTROUT' },
  "5.13.3" => { id => 'DAGOLDEN' },
  "5.13.4" => { id => 'FLORA' },
  "5.13.5" => { id => 'SHAY' },
  "5.13.6" => { id => 'MIYAGAWA' },
  "5.13.7" => { id => 'BINGOS' },
  "5.13.8" => { id => 'ZEFRAM' },
  "5.13.9" => { id => 'JESSE' },
  "5.13.10" => { id => 'AVAR' },
  "5.13.11" => { id => 'FLORA' },
  "5.14.0" => { id => 'JESSE' },
  "5.14.1" => { id => 'JESSE' },
  "5.14.2-RC1" => { id => 'FLORA' },
  "5.14.2" => { id => 'FLORA' },
  "5.14.3" => { id => 'DOM' },
  "5.14.4-RC1" => { id => 'DAPM' },
  "5.14.4-RC2" => { id => 'DAPM' },
  "5.14.4" => { id => 'DAPM' },
  "5.15.0" => { id => 'DAGOLDEN' },
  "5.15.1" => { id => 'ZEFRAM' },
  "5.15.2" => { id => 'RJBS' },
  "5.15.3" => { id => 'STEVAN' },
  "5.15.4" => { id => 'FLORA' },
  "5.15.5" => { id => 'SHAY' },
  "5.15.6" => { id => 'DROLSKY' },
  "5.15.7" => { id => 'BINGOS' },
  "5.15.8" => { id => 'CORION' },
  "5.15.9" => { id => 'ABIGAIL' },
  "5.16.0" => { id => 'RJBS' },
  "5.16.1" => { id => 'RJBS' },
  "5.16.2" => { id => 'RJBS' },
  "5.16.3" => { id => 'RJBS' },
  "5.17.0" => { id => 'ZEFRAM' },
  "5.17.1" => { id => 'DOY' },
  "5.17.2" => { id => 'TONYC' },
  "5.17.3" => { id => 'SHAY' },
  "5.17.4" => { id => 'FLORA' },
  "5.17.5" => { id => 'FLORA' },
  "5.17.6" => { id => 'RJBS' },
  "5.17.7" => { id => 'DROLSKY' },
  "5.17.8" => { id => 'ARC' },
  "5.17.9" => { id => 'BINGOS' },
  "5.17.10" => { id => 'CORION' },
  "5.17.11" => { id => 'RJBS' },
  "5.18.0-RC1" => { id => 'RJBS' },
  "5.18.0-RC2" => { id => 'RJBS' },
  "5.18.0-RC3" => { id => 'RJBS' },
  "5.18.0-RC4" => { id => 'RJBS' },
  "5.18.0" => { id => 'RJBS' },
  "5.18.1-RC1" => { id => 'RJBS' },
  "5.18.1-RC2" => { id => 'RJBS' },
  "5.18.1-RC3" => { id => 'RJBS' },
  "5.18.1" => { id => 'RJBS' },
  "5.19.0" => { id => 'RJBS' },
  "5.19.1" => { id => 'DAGOLDEN' },
  "5.19.2" => { id => 'ARISTOTLE' },
  "5.19.3" => { id => 'SHAY' },
  };
  
  sub perl_tarballs {
    my $vers = shift;
    $vers = shift if eval { $vers->isa(__PACKAGE__) };
    return unless exists $data->{ $vers };
    if ( exists $cache->{ $vers } ) {
      return { %{ $cache->{ $vers } } };
    }
    my $pumpkin = $data->{ $vers }->{id};
    my $path = join '/', substr( $pumpkin, 0, 1 ), substr( $pumpkin, 0, 2 ), $pumpkin;
    my $sep = ( $vers =~ m!^5\.0! ? '' : '-' );
    my $perl = join $sep, 'perl', $vers;
    my $onlygz = 1 if $vers =~ m!(?-xism:5.(?:00(?:4(?:_0[12345])?|5(?:_0[1234])?|3_07)|1(?:0.0(?:-RC[12])?|6.0-RC0)|6.(?:[02]|1(?:-TRIAL[123])?)|9.[12345]|7.[0123]|8.[01]))! || $data->{ $vers }->{onlygz};
    my $onlybz2 = 1 if $data->{ $vers }->{onlybz2};
    my $foo = { };
    $foo->{'tar.gz'} = "$path/$perl.tar.gz" unless $onlybz2;
    $foo->{'tar.bz2'} = "$path/$perl.tar.bz2" unless $onlygz;
    $cache->{ $vers } = $foo;
    return { %$foo };
  }
  
  sub perl_versions {
      return sort _by_version keys %$data;
  }
  
  
  sub _by_version {
    my %v = map {
      my @v = split(qr/[-._]0*/, $_);
      $v[2] ||= 0;
      $v[3] ||= 'Z';
      ($_ => sprintf '%d.%03d%03d-%s', @v)
    } $a, $b;
    $v{$a} cmp $v{$b};
  }
  
  sub perl_pumpkins {
      my %pumps = map { ( $data->{$_}->{id} => 1 ) } keys %$data;
      return sort keys %pumps;
  }
  
  q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  CPAN::Perl::Releases - Mapping Perl releases on CPAN to the location of the tarballs
  
  =head1 VERSION
  
  version 1.42
  
  =head1 SYNOPSIS
  
    use CPAN::Perl::Releases qw[perl_tarballs];
  
    my $perl = '5.14.0';
  
    my $hashref = perl_tarballs( $perl );
  
    print "Location: ", $_, "\n" for values %{ $hashref };
  
  =head1 DESCRIPTION
  
  CPAN::Perl::Releases is a module that contains the mappings of all C<perl> releases that have been uploaded to CPAN to the
  C<authors/id/> path that the tarballs reside in.
  
  This is static data, but newer versions of this module will be made available as new releases of C<perl> are uploaded to CPAN.
  
  =head1 FUNCTIONS
  
  =over
  
  =item C<perl_tarballs>
  
  Takes one parameter, a C<perl> version to search for. Returns an hashref on success or C<undef> otherwise.
  
  The returned hashref will have a key/value for each type of tarball. A key of C<tar.gz> indicates the location
  of a gzipped tar file and C<tar.bz2> of a bzip2'd tar file. The values will be the relative path under C<authors/id/>
  on CPAN where the indicated tarball will be located.
  
    perl_tarballs( '5.14.0' );
  
    Returns a hashref like:
  
    {
      "tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2",
      "tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz"
    }
  
  Not all C<perl> releases had C<tar.bz2>, but only a C<tar.gz>.
  
  =item C<perl_versions>
  
  Returns the list of all the perl versions supported by the module in ascending order. C<TRIAL> and C<RC> will be lower
  than an actual release.
  
  =item C<perl_pumpkins>
  
  Returns a sorted list of all PAUSE IDs of Perl pumpkins.
  
  =back
  
  =head1 SEE ALSO
  
  L<http://www.cpan.org/src/5.0/>
  
  L<http://search.cpan.org/faq.html#Is_there_a_API?>
  
  =head1 AUTHOR
  
  Chris Williams <chris@bingosnet.co.uk>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Chris Williams.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
CPAN_PERL_RELEASES

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

$fatpacked{"Encode/Locale.pm"} = <<'ENCODE_LOCALE';
  package Encode::Locale;
  
  use strict;
  our $VERSION = "1.03";
  
  use base 'Exporter';
  our @EXPORT_OK = qw(
      decode_argv env
      $ENCODING_LOCALE $ENCODING_LOCALE_FS
      $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT
  );
  
  use Encode ();
  use Encode::Alias ();
  
  our $ENCODING_LOCALE;
  our $ENCODING_LOCALE_FS;
  our $ENCODING_CONSOLE_IN;
  our $ENCODING_CONSOLE_OUT;
  
  sub DEBUG () { 0 }
  
  sub _init {
      if ($^O eq "MSWin32") {
  	unless ($ENCODING_LOCALE) {
  	    # Try to obtain what the Windows ANSI code page is
  	    eval {
  		unless (defined &GetACP) {
  		    require Win32::API;
  		    Win32::API->Import('kernel32', 'int GetACP()');
  		};
  		if (defined &GetACP) {
  		    my $cp = GetACP();
  		    $ENCODING_LOCALE = "cp$cp" if $cp;
  		}
  	    };
  	}
  
  	unless ($ENCODING_CONSOLE_IN) {
  	    # If we have the Win32::Console module installed we can ask
  	    # it for the code set to use
  	    eval {
  		require Win32::Console;
  		my $cp = Win32::Console::InputCP();
  		$ENCODING_CONSOLE_IN = "cp$cp" if $cp;
  		$cp = Win32::Console::OutputCP();
  		$ENCODING_CONSOLE_OUT = "cp$cp" if $cp;
  	    };
  	    # Invoking the 'chcp' program might also work
  	    if (!$ENCODING_CONSOLE_IN && (qx(chcp) || '') =~ /^Active code page: (\d+)/) {
  		$ENCODING_CONSOLE_IN = "cp$1";
  	    }
  	}
      }
  
      unless ($ENCODING_LOCALE) {
  	eval {
  	    require I18N::Langinfo;
  	    $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
  
  	    # Workaround of Encode < v2.25.  The "646" encoding  alias was
  	    # introduced in Encode-2.25, but we don't want to require that version
  	    # quite yet.  Should avoid the CPAN testers failure reported from
  	    # openbsd-4.7/perl-5.10.0 combo.
  	    $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646";
  
  	    # https://rt.cpan.org/Ticket/Display.html?id=66373
  	    $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8";
  	};
  	$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
      }
  
      if ($^O eq "darwin") {
  	$ENCODING_LOCALE_FS ||= "UTF-8";
      }
  
      # final fallback
      $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";
      $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;
      $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;
      $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;
  
      unless (Encode::find_encoding($ENCODING_LOCALE)) {
  	my $foundit;
  	if (lc($ENCODING_LOCALE) eq "gb18030") {
  	    eval {
  		require Encode::HanExtra;
  	    };
  	    if ($@) {
  		die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped";
  	    }
  	    $foundit++ if Encode::find_encoding($ENCODING_LOCALE);
  	}
  	die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped"
  	    unless $foundit;
  
      }
  
      # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT;
  }
  
  _init();
  Encode::Alias::define_alias(sub {
      no strict 'refs';
      no warnings 'once';
      return ${"ENCODING_" . uc(shift)};
  }, "locale");
  
  sub _flush_aliases {
      no strict 'refs';
      for my $a (keys %Encode::Alias::Alias) {
  	if (defined ${"ENCODING_" . uc($a)}) {
  	    delete $Encode::Alias::Alias{$a};
  	    warn "Flushed alias cache for $a" if DEBUG;
  	}
      }
  }
  
  sub reinit {
      $ENCODING_LOCALE = shift;
      $ENCODING_LOCALE_FS = shift;
      $ENCODING_CONSOLE_IN = $ENCODING_LOCALE;
      $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE;
      _init();
      _flush_aliases();
  }
  
  sub decode_argv {
      die if defined wantarray;
      for (@ARGV) {
  	$_ = Encode::decode(locale => $_, @_);
      }
  }
  
  sub env {
      my $k = Encode::encode(locale => shift);
      my $old = $ENV{$k};
      if (@_) {
  	my $v = shift;
  	if (defined $v) {
  	    $ENV{$k} = Encode::encode(locale => $v);
  	}
  	else {
  	    delete $ENV{$k};
  	}
      }
      return Encode::decode(locale => $old) if defined wantarray;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Encode::Locale - Determine the locale encoding
  
  =head1 SYNOPSIS
  
    use Encode::Locale;
    use Encode;
  
    $string = decode(locale => $bytes);
    $bytes = encode(locale => $string);
  
    if (-t) {
        binmode(STDIN, ":encoding(console_in)");
        binmode(STDOUT, ":encoding(console_out)");
        binmode(STDERR, ":encoding(console_out)");
    }
  
    # Processing file names passed in as arguments
    my $uni_filename = decode(locale => $ARGV[0]);
    open(my $fh, "<", encode(locale_fs => $uni_filename))
       || die "Can't open '$uni_filename': $!";
    binmode($fh, ":encoding(locale)");
    ...
  
  =head1 DESCRIPTION
  
  In many applications it's wise to let Perl use Unicode for the strings it
  processes.  Most of the interfaces Perl has to the outside world are still byte
  based.  Programs therefore need to decode byte strings that enter the program
  from the outside and encode them again on the way out.
  
  The POSIX locale system is used to specify both the language conventions
  requested by the user and the preferred character set to consume and
  output.  The C<Encode::Locale> module looks up the charset and encoding (called
  a CODESET in the locale jargon) and arranges for the L<Encode> module to know
  this encoding under the name "locale".  It means bytes obtained from the
  environment can be converted to Unicode strings by calling C<<
  Encode::encode(locale => $bytes) >> and converted back again with C<<
  Encode::decode(locale => $string) >>.
  
  Where file systems interfaces pass file names in and out of the program we also
  need care.  The trend is for operating systems to use a fixed file encoding
  that don't actually depend on the locale; and this module determines the most
  appropriate encoding for file names. The L<Encode> module will know this
  encoding under the name "locale_fs".  For traditional Unix systems this will
  be an alias to the same encoding as "locale".
  
  For programs running in a terminal window (called a "Console" on some systems)
  the "locale" encoding is usually a good choice for what to expect as input and
  output.  Some systems allows us to query the encoding set for the terminal and
  C<Encode::Locale> will do that if available and make these encodings known
  under the C<Encode> aliases "console_in" and "console_out".  For systems where
  we can't determine the terminal encoding these will be aliased as the same
  encoding as "locale".  The advice is to use "console_in" for input known to
  come from the terminal and "console_out" for output known to go from the
  terminal.
  
  In addition to arranging for various Encode aliases the following functions and
  variables are provided:
  
  =over
  
  =item decode_argv( )
  
  =item decode_argv( Encode::FB_CROAK )
  
  This will decode the command line arguments to perl (the C<@ARGV> array) in-place.
  
  The function will by default replace characters that can't be decoded by
  "\x{FFFD}", the Unicode replacement character.
  
  Any argument provided is passed as CHECK to underlying Encode::decode() call.
  Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the
  command line arguments can be decoded.  See L<Encode/"Handling Malformed Data">
  for details on other options for CHECK.
  
  =item env( $uni_key )
  
  =item env( $uni_key => $uni_value )
  
  Interface to get/set environment variables.  Returns the current value as a
  Unicode string. The $uni_key and $uni_value arguments are expected to be
  Unicode strings as well.  Passing C<undef> as $uni_value deletes the
  environment variable named $uni_key.
  
  The returned value will have the characters that can't be decoded replaced by
  "\x{FFFD}", the Unicode replacement character.
  
  There is no interface to request alternative CHECK behavior as for
  decode_argv().  If you need that you need to call encode/decode yourself.
  For example:
  
      my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK);
      my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK);
  
  =item reinit( )
  
  =item reinit( $encoding )
  
  Reinitialize the encodings from the locale.  You want to call this function if
  you changed anything in the environment that might influence the locale.
  
  This function will croak if the determined encoding isn't recognized by
  the Encode module.
  
  With argument force $ENCODING_... variables to set to the given value.
  
  =item $ENCODING_LOCALE
  
  The encoding name determined to be suitable for the current locale.
  L<Encode> know this encoding as "locale".
  
  =item $ENCODING_LOCALE_FS
  
  The encoding name determined to be suiteable for file system interfaces
  involving file names.
  L<Encode> know this encoding as "locale_fs".
  
  =item $ENCODING_CONSOLE_IN
  
  =item $ENCODING_CONSOLE_OUT
  
  The encodings to be used for reading and writing output to the a console.
  L<Encode> know these encodings as "console_in" and "console_out".
  
  =back
  
  =head1 NOTES
  
  This table summarizes the mapping of the encodings set up
  by the C<Encode::Locale> module:
  
    Encode      |         |              |
    Alias       | Windows | Mac OS X     | POSIX
    ------------+---------+--------------+------------
    locale      | ANSI    | nl_langinfo  | nl_langinfo
    locale_fs   | ANSI    | UTF-8        | nl_langinfo
    console_in  | OEM     | nl_langinfo  | nl_langinfo
    console_out | OEM     | nl_langinfo  | nl_langinfo
  
  =head2 Windows
  
  Windows has basically 2 sets of APIs.  A wide API (based on passing UTF-16
  strings) and a byte based API based a character set called ANSI.  The
  regular Perl interfaces to the OS currently only uses the ANSI APIs.
  Unfortunately ANSI is not a single character set.
  
  The encoding that corresponds to ANSI varies between different editions of
  Windows.  For many western editions of Windows ANSI corresponds to CP-1252
  which is a character set similar to ISO-8859-1.  Conceptually the ANSI
  character set is a similar concept to the POSIX locale CODESET so this module
  figures out what the ANSI code page is and make this available as
  $ENCODING_LOCALE and the "locale" Encoding alias.
  
  Windows systems also operate with another byte based character set.
  It's called the OEM code page.  This is the encoding that the Console
  takes as input and output.  It's common for the OEM code page to
  differ from the ANSI code page.
  
  =head2 Mac OS X
  
  On Mac OS X the file system encoding is always UTF-8 while the locale
  can otherwise be set up as normal for POSIX systems.
  
  File names on Mac OS X will at the OS-level be converted to
  NFD-form.  A file created by passing a NFC-filename will come
  in NFD-form from readdir().  See L<Unicode::Normalize> for details
  of NFD/NFC.
  
  Actually, Apple does not follow the Unicode NFD standard since not all
  character ranges are decomposed.  The claim is that this avoids problems with
  round trip conversions from old Mac text encodings.  See L<Encode::UTF8Mac> for
  details.
  
  =head2 POSIX (Linux and other Unixes)
  
  File systems might vary in what encoding is to be used for
  filenames.  Since this module has no way to actually figure out
  what the is correct it goes with the best guess which is to
  assume filenames are encoding according to the current locale.
  Users are advised to always specify UTF-8 as the locale charset.
  
  =head1 SEE ALSO
  
  L<I18N::Langinfo>, L<Encode>
  
  =head1 AUTHOR
  
  Copyright 2010 Gisle Aas <gisle@aas.no>.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
ENCODE_LOCALE

$fatpacked{"Fatal.pm"} = <<'FATAL';
  package Fatal;
  
  # ABSTRACT: Replace functions with equivalents which succeed or die
  
  use 5.008;  # 5.8.x needed for autodie
  use Carp;
  use strict;
  use warnings;
  use Tie::RefHash;   # To cache subroutine refs
  use Config;
  use Scalar::Util qw(set_prototype);
  
  use constant PERL510     => ( $] >= 5.010 );
  
  use constant LEXICAL_TAG => q{:lexical};
  use constant VOID_TAG    => q{:void};
  use constant INSIST_TAG  => q{!};
  
  use constant ERROR_NOARGS    => 'Cannot use lexical %s with no arguments';
  use constant ERROR_VOID_LEX  => VOID_TAG.' cannot be used with lexical scope';
  use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
  use constant ERROR_NO_LEX    => "no %s can only start with ".LEXICAL_TAG;
  use constant ERROR_BADNAME   => "Bad subroutine name for %s: %s";
  use constant ERROR_NOTSUB    => "%s is not a Perl subroutine";
  use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
  use constant ERROR_NOHINTS   => "No user hints defined for %s";
  
  use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
  
  use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
  
  use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system().  We only have version %f";
  
  use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
  
  use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
  
  use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
  
  # Older versions of IPC::System::Simple don't support all the
  # features we need.
  
  use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
  
  our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version
  
  our $Debug ||= 0;
  
  # EWOULDBLOCK values for systems that don't supply their own.
  # Even though this is defined with our, that's to help our
  # test code.  Please don't rely upon this variable existing in
  # the future.
  
  our %_EWOULDBLOCK = (
      MSWin32 => 33,
  );
  
  # the linux parisc port has separate EAGAIN and EWOULDBLOCK,
  # and the kernel returns EAGAIN
  my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
  
  # We have some tags that can be passed in for use with import.
  # These are all assumed to be CORE::
  
  my %TAGS = (
      ':io'      => [qw(:dbm :file :filesys :ipc :socket
                         read seek sysread syswrite sysseek )],
      ':dbm'     => [qw(dbmopen dbmclose)],
      ':file'    => [qw(open close flock sysopen fcntl fileno binmode
                       ioctl truncate)],
      ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
                        symlink rmdir readlink umask chmod chown utime)],
      ':ipc'     => [qw(:msg :semaphore :shm pipe kill)],
      ':msg'     => [qw(msgctl msgget msgrcv msgsnd)],
      ':threads' => [qw(fork)],
      ':semaphore'=>[qw(semctl semget semop)],
      ':shm'     => [qw(shmctl shmget shmread)],
      ':system'  => [qw(system exec)],
  
      # Can we use qw(getpeername getsockname)? What do they do on failure?
      # TODO - Can socket return false?
      ':socket'  => [qw(accept bind connect getsockopt listen recv send
                     setsockopt shutdown socketpair)],
  
      # Our defaults don't include system(), because it depends upon
      # an optional module, and it breaks the exotic form.
      #
      # This *may* change in the future.  I'd love IPC::System::Simple
      # to be a dependency rather than a recommendation, and hence for
      # system() to be autodying by default.
  
      ':default' => [qw(:io :threads)],
  
      # Everything in v2.07 and brefore. This was :default less chmod and chown
      ':v207'    => [qw(:threads :dbm :socket read seek sysread
                     syswrite sysseek open close flock sysopen fcntl fileno
                     binmode ioctl truncate opendir closedir chdir link unlink
                     rename mkdir symlink rmdir readlink umask
                     :msg :semaphore :shm pipe)],
  
      # Chmod was added in 2.13
      ':v213'    => [qw(:v207 chmod)],
  
      # chown, utime, kill were added in 2.14
      ':v214'    => [qw(:v213 chown utime kill)],
  
      # Version specific tags.  These allow someone to specify
      # use autodie qw(:1.994) and know exactly what they'll get.
  
      ':1.994' => [qw(:v207)],
      ':1.995' => [qw(:v207)],
      ':1.996' => [qw(:v207)],
      ':1.997' => [qw(:v207)],
      ':1.998' => [qw(:v207)],
      ':1.999' => [qw(:v207)],
      ':1.999_01' => [qw(:v207)],
      ':2.00'  => [qw(:v207)],
      ':2.01'  => [qw(:v207)],
      ':2.02'  => [qw(:v207)],
      ':2.03'  => [qw(:v207)],
      ':2.04'  => [qw(:v207)],
      ':2.05'  => [qw(:v207)],
      ':2.06'  => [qw(:v207)],
      ':2.06_01' => [qw(:v207)],
      ':2.07'  => [qw(:v207)],     # Last release without chmod
      ':2.08'  => [qw(:v213)],
      ':2.09'  => [qw(:v213)],
      ':2.10'  => [qw(:v213)],
      ':2.11'  => [qw(:v213)],
      ':2.12'  => [qw(:v213)],
      ':2.13'  => [qw(:v213)],
      ':2.14'  => [qw(:default)],
      ':2.15'  => [qw(:default)],
      ':2.16'  => [qw(:default)],
      ':2.17'  => [qw(:default)],
      ':2.18'  => [qw(:default)],
      ':2.19'  => [qw(:default)],
      ':2.20'  => [qw(:default)],
  );
  
  # chmod was only introduced in 2.07
  # chown was only introduced in 2.14
  
  $TAGS{':all'}  = [ keys %TAGS ];
  
  # This hash contains subroutines for which we should
  # subroutine() // die() rather than subroutine() || die()
  
  my %Use_defined_or;
  
  # CORE::open returns undef on failure.  It can legitimately return
  # 0 on success, eg: open(my $fh, '-|') || exec(...);
  
  @Use_defined_or{qw(
      CORE::fork
      CORE::recv
      CORE::send
      CORE::open
      CORE::fileno
      CORE::read
      CORE::readlink
      CORE::sysread
      CORE::syswrite
      CORE::sysseek
      CORE::umask
  )} = ();
  
  # Some functions can return true because they changed *some* things, but
  # not all of them.  This is a list of offending functions, and how many
  # items to subtract from @_ to determine the "success" value they return.
  
  my %Returns_num_things_changed = (
      'CORE::chmod'  => 1,
      'CORE::chown'  => 2,
      'CORE::kill'   => 1,  # TODO: Could this return anything on negative args?
      'CORE::unlink' => 0,
      'CORE::utime'  => 2,
  );
  
  # Optional actions to take on the return value before returning it.
  
  my %Retval_action = (
      "CORE::open"        => q{
  
      # apply the open pragma from our caller
      if( defined $retval ) {
          # Get the caller's hint hash
          my $hints = (caller 0)[10];
  
          # Decide if we're reading or writing and apply the appropriate encoding
          # These keys are undocumented.
          # Match what PerlIO_context_layers() does.  Read gets the read layer,
          # everything else gets the write layer.
          my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"};
  
          # Apply the encoding, if any.
          if( $encoding ) {
              binmode $_[0], $encoding;
          }
      }
  
  },
      "CORE::sysopen"     => q{
  
      # apply the open pragma from our caller
      if( defined $retval ) {
          # Get the caller's hint hash
          my $hints = (caller 0)[10];
  
          require Fcntl;
  
          # Decide if we're reading or writing and apply the appropriate encoding.
          # Match what PerlIO_context_layers() does.  Read gets the read layer,
          # everything else gets the write layer.
          my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY());
          my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"};
  
          # Apply the encoding, if any.
          if( $encoding ) {
              binmode $_[0], $encoding;
          }
      }
  
  },
  );
  
  my %reusable_builtins;
  
  # "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can
  # take file and directory handles, which are package depedent."
  #
  # You would be correct, except that prototype() returns signatures which don't
  # allow for passing of globs, and nobody's complained about that. You can
  # still use \*FILEHANDLE, but that results in a reference coming through,
  # and it's already pointing to the filehandle in the caller's packge, so
  # it's all okay.
  
  @reusable_builtins{qw(
      CORE::fork
      CORE::kill
      CORE::truncate
      CORE::chdir
      CORE::link
      CORE::unlink
      CORE::rename
      CORE::mkdir
      CORE::symlink
      CORE::rmdir
      CORE::readlink
      CORE::umask
      CORE::chmod
      CORE::chown
      CORE::utime
      CORE::msgctl
      CORE::msgget
      CORE::msgrcv
      CORE::msgsnd
      CORE::semctl
      CORE::semget
      CORE::semop
      CORE::shmctl
      CORE::shmget
      CORE::shmread
  )} = ();
  
  # Cached_fatalised_sub caches the various versions of our
  # fatalised subs as they're produced.  This means we don't
  # have to build our own replacement of CORE::open and friends
  # for every single package that wants to use them.
  
  my %Cached_fatalised_sub = ();
  
  # Every time we're called with package scope, we record the subroutine
  # (including package or CORE::) in %Package_Fatal.  This allows us
  # to detect illegal combinations of autodie and Fatal, and makes sure
  # we don't accidently make a Fatal function autodying (which isn't
  # very useful).
  
  my %Package_Fatal = ();
  
  # The first time we're called with a user-sub, we cache it here.
  # In the case of a "no autodie ..." we put back the cached copy.
  
  my %Original_user_sub = ();
  
  # Is_fatalised_sub simply records a big map of fatalised subroutine
  # refs.  It means we can avoid repeating work, or fatalising something
  # we've already processed.
  
  my  %Is_fatalised_sub = ();
  tie %Is_fatalised_sub, 'Tie::RefHash';
  
  # Our trampoline cache allows us to cache trampolines which are used to
  # bounce leaked wrapped core subroutines to their actual core counterparts.
  
  my %Trampoline_cache;
  
  # We use our package in a few hash-keys.  Having it in a scalar is
  # convenient.  The "guard $PACKAGE" string is used as a key when
  # setting up lexical guards.
  
  my $PACKAGE       = __PACKAGE__;
  my $PACKAGE_GUARD = "guard $PACKAGE";
  my $NO_PACKAGE    = "no $PACKAGE";      # Used to detect 'no autodie'
  
  # Here's where all the magic happens when someone write 'use Fatal'
  # or 'use autodie'.
  
  sub import {
      my $class        = shift(@_);
      my @original_args = @_;
      my $void         = 0;
      my $lexical      = 0;
      my $insist_hints = 0;
  
      my ($pkg, $filename) = caller();
  
      @_ or return;   # 'use Fatal' is a no-op.
  
      # If we see the :lexical flag, then _all_ arguments are
      # changed lexically
  
      if ($_[0] eq LEXICAL_TAG) {
          $lexical = 1;
          shift @_;
  
          # If we see no arguments and :lexical, we assume they
          # wanted ':default'.
  
          if (@_ == 0) {
              push(@_, ':default');
          }
  
          # Don't allow :lexical with :void, it's needlessly confusing.
          if ( grep { $_ eq VOID_TAG } @_ ) {
              croak(ERROR_VOID_LEX);
          }
      }
  
      if ( grep { $_ eq LEXICAL_TAG } @_ ) {
          # If we see the lexical tag as the non-first argument, complain.
          croak(ERROR_LEX_FIRST);
      }
  
      my @fatalise_these =  @_;
  
      # Thiese subs will get unloaded at the end of lexical scope.
      my %unload_later;
  
      # Use _translate_import_args to expand tags for us.  It will
      # pass-through unknown tags (i.e. we have to manually handle
      # VOID_TAG).
      #
      # TODO: Consider how to handle stuff like:
      #   use autodie qw(:defaults ! :io);
      #   use Fatal qw(:defaults :void :io);
      #
      # The ! and :void is currently not applied to anything in the
      # example above since duplicates are filtered out.  This has been
      # autodie's behaviour for quite a while, but it might make sense
      # to change it so "!" or ":void" applies to stuff after they
      # appear (even if they are all duplicates).
      for my $func ($class->_translate_import_args(@fatalise_these)) {
  
          if ($func eq VOID_TAG) {
  
              # When we see :void, set the void flag.
              $void = 1;
  
          } elsif ($func eq INSIST_TAG) {
  
              $insist_hints = 1;
  
          } else {
  
              # Otherwise, fatalise it.
  
              # Check to see if there's an insist flag at the front.
              # If so, remove it, and insist we have hints for this sub.
              my $insist_this;
  
              if ($func =~ s/^!//) {
                  $insist_this = 1;
              }
  
              # We're going to make a subroutine fatalistic.
              # However if we're being invoked with 'use Fatal qw(x)'
              # and we've already been called with 'no autodie qw(x)'
              # in the same scope, we consider this to be an error.
              # Mixing Fatal and autodie effects was considered to be
              # needlessly confusing on p5p.
  
              my $sub = $func;
              $sub = "${pkg}::$sub" unless $sub =~ /::/;
  
              # If we're being called as Fatal, and we've previously
              # had a 'no X' in scope for the subroutine, then complain
              # bitterly.
  
              if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
                   croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
              }
  
              # We're not being used in a confusing way, so make
              # the sub fatal.  Note that _make_fatal returns the
              # old (original) version of the sub, or undef for
              # built-ins.
  
              my $sub_ref = $class->_make_fatal(
                  $func, $pkg, $void, $lexical, $filename,
                  ( $insist_this || $insist_hints )
              );
  
              $Original_user_sub{$sub} ||= $sub_ref;
  
              # If we're making lexical changes, we need to arrange
              # for them to be cleaned at the end of our scope, so
              # record them here.
  
              $unload_later{$func} = $sub_ref if $lexical;
          }
      }
  
      if ($lexical) {
  
          # Dark magic to have autodie work under 5.8
          # Copied from namespace::clean, that copied it from
          # autobox, that found it on an ancient scroll written
          # in blood.
  
          # This magic bit causes %^H to be lexically scoped.
  
          $^H |= 0x020000;
  
          # Our package guard gets invoked when we leave our lexical
          # scope.
  
          push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
              $class->_install_subs($pkg, \%unload_later);
          }));
  
          # To allow others to determine when autodie was in scope,
          # and with what arguments, we also set a %^H hint which
          # is how we were called.
  
          # This feature should be considered EXPERIMENTAL, and
          # may change without notice.  Please e-mail pjf@cpan.org
          # if you're actually using it.
  
          $^H{autodie} = "$PACKAGE @original_args";
  
      }
  
      return;
  
  }
  
  # The code here is originally lifted from namespace::clean,
  # by Robert "phaylon" Sedlacek.
  #
  # It's been redesigned after feedback from ikegami on perlmonks.
  # See http://perlmonks.org/?node_id=693338 .  Ikegami rocks.
  #
  # Given a package, and hash of (subname => subref) pairs,
  # we install the given subroutines into the package.  If
  # a subref is undef, the subroutine is removed.  Otherwise
  # it replaces any existing subs which were already there.
  
  sub _install_subs {
      my ($class, $pkg, $subs_to_reinstate) = @_;
  
      my $pkg_sym = "${pkg}::";
  
      # It does not hurt to do this in a predictable order, and might help debugging.
      foreach my $sub_name (sort keys %$subs_to_reinstate) {
          my $sub_ref= $subs_to_reinstate->{$sub_name};
  
          my $full_path = $pkg_sym.$sub_name;
  
          # Copy symbols across to temp area.
  
          no strict 'refs';   ## no critic
  
          local *__tmp = *{ $full_path };
  
          # Nuke the old glob.
          { no strict; delete $pkg_sym->{$sub_name}; }    ## no critic
  
          # Copy innocent bystanders back.  Note that we lose
          # formats; it seems that Perl versions up to 5.10.0
          # have a bug which causes copying formats to end up in
          # the scalar slot.  Thanks to Ben Morrow for spotting this.
  
          foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
              next unless defined *__tmp{ $slot };
              *{ $full_path } = *__tmp{ $slot };
          }
  
          # Put back the old sub (if there was one).
  
          if ($sub_ref) {
  
              no strict;  ## no critic
              *{ $full_path } = $sub_ref;
          }
      }
  
      return;
  }
  
  sub unimport {
      my $class = shift;
  
      # Calling "no Fatal" must start with ":lexical"
      if ($_[0] ne LEXICAL_TAG) {
          croak(sprintf(ERROR_NO_LEX,$class));
      }
  
      shift @_;   # Remove :lexical
  
      my $pkg = (caller)[0];
  
      # If we've been called with arguments, then the developer
      # has explicitly stated 'no autodie qw(blah)',
      # in which case, we disable Fatalistic behaviour for 'blah'.
  
      my @unimport_these = @_ ? @_ : ':all';
  
      for my $symbol ($class->_translate_import_args(@unimport_these)) {
  
          my $sub = $symbol;
          $sub = "${pkg}::$sub" unless $sub =~ /::/;
  
          # If 'blah' was already enabled with Fatal (which has package
          # scope) then, this is considered an error.
  
          if (exists $Package_Fatal{$sub}) {
              croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
          }
  
          # Record 'no autodie qw($sub)' as being in effect.
          # This is to catch conflicting semantics elsewhere
          # (eg, mixing Fatal with no autodie)
  
          $^H{$NO_PACKAGE}{$sub} = 1;
  
          if (my $original_sub = $Original_user_sub{$sub}) {
              # Hey, we've got an original one of these, put it back.
              $class->_install_subs($pkg, { $symbol => $original_sub });
              next;
          }
  
          # We don't have an original copy of the sub, on the assumption
          # it's core (or doesn't exist), we'll just nuke it.
  
          $class->_install_subs($pkg,{ $symbol => undef });
  
      }
  
      return;
  
  }
  
  sub _translate_import_args {
      my ($class, @args) = @_;
      my @result;
      for my $a (@args){
          if (exists $TAGS{$a}) {
              my $expanded = $class->_expand_tag($a);
              # Strip "CORE::" from all elements in the list as import and
              # unimport does not handle the "CORE::" prefix too well.
              #
              # NB: we use substr as it is faster than s/^CORE::// and
              # it does not change the elements.
              push @result, map { substr($_, 6) } @{$expanded};
          } else {
              #pass through
              push @result, $a;
          }
      }
      # If @args < 2, then we have no duplicates (because _expand_tag
      # does not have duplicates and if it is not a tag, it is just a
      # single value).  We optimize for this because it is a fairly
      # common case (e.g. use autodie; or use autodie qw(:all); both
      # trigger this).
      return @result if @args < 2;
  
      my %seen = ();
      # Yes, this is basically List::MoreUtils's uniq/distinct, but
      # List::MoreUtils is not in the Perl core and autodie is
      return grep { !$seen{$_}++ } @result;
  }
  
  
  # NB: Perl::Critic's dump-autodie-tag-contents depends upon this
  # continuing to work.
  
  {
      my %tag_cache;
  
      # Expand a given tag (e.g. ":default") into a listref containing
      # all sub names covered by that tag.  Each sub is returned as
      # "CORE::<name>" (i.e. "CORE::open" rather than "open").
      #
      # NB: the listref must not be modified.
      sub _expand_tag {
          my ($class, $tag) = @_;
  
          if (my $cached = $tag_cache{$tag}) {
              return $cached;
          }
  
          if (not exists $TAGS{$tag}) {
              croak "Invalid exception class $tag";
          }
  
          my @to_process = @{$TAGS{$tag}};
  
          # If the tag is basically an alias of another tag (like e.g. ":2.11"),
          # then just share the resulting reference with the original content (so
          # we only pay for an extra reference for the alias memory-wise).
          if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') {
              # We could do this for "non-tags" as well, but that only occurs
              # once at the time of writing (":threads" => ["fork"]), so
              # probably not worth it.
              my $expanded = $class->_expand_tag($to_process[0]);
              $tag_cache{$tag} = $expanded;
              return $expanded;
          }
  
          my %seen = ();
          my @taglist = ();
  
          for my $item (@to_process) {
              # substr is more efficient than m/^:/ for stuff like this,
              # at the price of being a bit more verbose/low-level.
              if (substr($item, 0, 1) eq ':') {
                  # Use recursion here to ensure we expand a tag at most once.
                  #
                  # TODO: Improve handling of :all so we don't expand
                  # all those aliases (e.g :2.00..:2.07 are all aliases
                  # of v2.07).
  
                  my $expanded = $class->_expand_tag($item);
                  push @taglist, grep { !$seen{$_}++ } @{$expanded};
              } else {
                  my $subname = "CORE::$item";
                  push @taglist, $subname
                      unless $seen{$subname}++;
              }
          }
  
          $tag_cache{$tag} = \@taglist;
  
          return \@taglist;
  
      }
  
  }
  
  # This code is from the original Fatal.  It scares me.
  # It is 100% compatible with the 5.10.0 Fatal module, right down
  # to the scary 'XXXX' comment.  ;)
  
  sub fill_protos {
      my $proto = shift;
      my ($n, $isref, @out, @out1, $seen_semi) = -1;
      if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) {
          # prototype is entirely slurp - special case that does not
          # require any handling.
          return ([0, '@_']);
      }
  
      while ($proto =~ /\S/) {
          $n++;
          push(@out1,[$n,@out]) if $seen_semi;
          push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
          push(@out, "\$_[$n]"),        next if $proto =~ s/^\s*([_*\$&])//;
          push(@out, "\@_[$n..\$#_]"),  last if $proto =~ s/^\s*(;\s*)?\@//;
          $seen_semi = 1, $n--,         next if $proto =~ s/^\s*;//; # XXXX ????
          die "Internal error: Unknown prototype letters: \"$proto\"";
      }
      push(@out1,[$n+1,@out]);
      return @out1;
  }
  
  # This is a backwards compatible version of _write_invocation.  It's
  # recommended you don't use it.
  
  sub write_invocation {
      my ($core, $call, $name, $void, @args) = @_;
  
      return Fatal->_write_invocation(
          $core, $call, $name, $void,
          0,      # Lexical flag
          undef,  # Sub, unused in legacy mode
          undef,  # Subref, unused in legacy mode.
          @args
      );
  }
  
  # This version of _write_invocation is used internally.  It's not
  # recommended you call it from external code, as the interface WILL
  # change in the future.
  
  sub _write_invocation {
  
      my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
  
      if (@argvs == 1) {        # No optional arguments
  
          my @argv = @{$argvs[0]};
          shift @argv;
  
          return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
  
      } else {
          my $else = "\t";
          my (@out, @argv, $n);
          while (@argvs) {
              @argv = @{shift @argvs};
              $n = shift @argv;
  
              my $condition = "\@_ == $n";
  
              if (@argv and $argv[-1] =~ /[#@]_/) {
                  # This argv ends with '@' in the prototype, so it matches
                  # any number of args >= the number of expressions in the
                  # argv.
                  $condition = "\@_ >= $n";
              }
  
              push @out, "${else}if ($condition) {\n";
  
              $else = "\t} els";
  
          push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
          }
          push @out, qq[
              }
              die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
      ];
  
          return join '', @out;
      }
  }
  
  
  # This is a slim interface to ensure backward compatibility with
  # anyone doing very foolish things with old versions of Fatal.
  
  sub one_invocation {
      my ($core, $call, $name, $void, @argv) = @_;
  
      return Fatal->_one_invocation(
          $core, $call, $name, $void,
          undef,   # Sub.  Unused in back-compat mode.
          1,       # Back-compat flag
          undef,   # Subref, unused in back-compat mode.
          @argv
      );
  
  }
  
  # This is the internal interface that generates code.
  # NOTE: This interface WILL change in the future.  Please do not
  # call this subroutine directly.
  
  # TODO: Whatever's calling this code has already looked up hints.  Pass
  # them in, rather than look them up a second time.
  
  sub _one_invocation {
      my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
  
  
      # If someone is calling us directly (a child class perhaps?) then
      # they could try to mix void without enabling backwards
      # compatibility.  We just don't support this at all, so we gripe
      # about it rather than doing something unwise.
  
      if ($void and not $back_compat) {
          Carp::confess("Internal error: :void mode not supported with $class");
      }
  
      # @argv only contains the results of the in-built prototype
      # function, and is therefore safe to interpolate in the
      # code generators below.
  
      # TODO - The following clobbers context, but that's what the
      #        old Fatal did.  Do we care?
  
      if ($back_compat) {
  
          # Use Fatal qw(system) will never be supported.  It generated
          # a compile-time error with legacy Fatal, and there's no reason
          # to support it when autodie does a better job.
  
          if ($call eq 'CORE::system') {
              return q{
                  croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
              };
          }
  
          local $" = ', ';
  
          if ($void) {
              return qq/return (defined wantarray)?$call(@argv):
                     $call(@argv) || Carp::croak("Can't $name(\@_)/ .
                     ($core ? ': $!' : ', \$! is \"$!\"') . '")'
          } else {
              return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
                     ($core ? ': $!' : ', \$! is \"$!\"') . '")';
          }
      }
  
      # The name of our original function is:
      #   $call if the function is CORE
      #   $sub if our function is non-CORE
  
      # The reason for this is that $call is what we're actually
      # calling.  For our core functions, this is always
      # CORE::something.  However for user-defined subs, we're about to
      # replace whatever it is that we're calling; as such, we actually
      # calling a subroutine ref.
  
      my $human_sub_name = $core ? $call : $sub;
  
      # Should we be testing to see if our result is defined, or
      # just true?
  
      my $use_defined_or;
  
      my $hints;      # All user-sub hints, including list hints.
  
      if ( $core ) {
  
          # Core hints are built into autodie.
  
          $use_defined_or = exists ( $Use_defined_or{$call} );
  
      }
      else {
  
          # User sub hints are looked up using autodie::hints,
          # since users may wish to add their own hints.
  
          require autodie::hints;
  
          $hints = autodie::hints->get_hints_for( $sref );
  
          # We'll look up the sub's fullname.  This means we
          # get better reports of where it came from in our
          # error messages, rather than what imported it.
  
          $human_sub_name = autodie::hints->sub_fullname( $sref );
  
      }
  
      # Checks for special core subs.
  
      if ($call eq 'CORE::system') {
  
          # Leverage IPC::System::Simple if we're making an autodying
          # system.
  
          local $" = ", ";
  
          # We need to stash $@ into $E, rather than using
          # local $@ for the whole sub.  If we don't then
          # any exceptions from internal errors in autodie/Fatal
          # will mysteriously disappear before propagating
          # upwards.
  
          return qq{
              my \$retval;
              my \$E;
  
  
              {
                  local \$@;
  
                  eval {
                      \$retval = IPC::System::Simple::system(@argv);
                  };
  
                  \$E = \$@;
              }
  
              if (\$E) {
  
                  # TODO - This can't be overridden in child
                  # classes!
  
                  die autodie::exception::system->new(
                      function => q{CORE::system}, args => [ @argv ],
                      message => "\$E", errno => \$!,
                  );
              }
  
              return \$retval;
          };
  
      }
  
      local $" = ', ';
  
      # If we're going to throw an exception, here's the code to use.
      my $die = qq{
          die $class->throw(
              function => q{$human_sub_name}, args => [ @argv ],
              pragma => q{$class}, errno => \$!,
              context => \$context, return => \$retval,
              eval_error => \$@
          )
      };
  
      if ($call eq 'CORE::flock') {
  
          # flock needs special treatment.  When it fails with
          # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
          # means we couldn't get the lock right now.
  
          require POSIX;      # For POSIX::EWOULDBLOCK
  
          local $@;   # Don't blat anyone else's $@.
  
          # Ensure that our vendor supports EWOULDBLOCK.  If they
          # don't (eg, Windows), then we use known values for its
          # equivalent on other systems.
  
          my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
                            || $_EWOULDBLOCK{$^O}
                            || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
          my $EAGAIN = $EWOULDBLOCK;
          if ($try_EAGAIN) {
              $EAGAIN = eval { POSIX::EAGAIN(); }
                            || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
          }
  
          require Fcntl;      # For Fcntl::LOCK_NB
  
          return qq{
  
              my \$context = wantarray() ? "list" : "scalar";
  
              # Try to flock.  If successful, return it immediately.
  
              my \$retval = $call(@argv);
              return \$retval if \$retval;
  
              # If we failed, but we're using LOCK_NB and
              # returned EWOULDBLOCK, it's not a real error.
  
              if (\$_[1] & Fcntl::LOCK_NB() and
                  (\$! == $EWOULDBLOCK or
                  ($try_EAGAIN and \$! == $EAGAIN ))) {
                  return \$retval;
              }
  
              # Otherwise, we failed.  Die noisily.
  
              $die;
  
          };
      }
  
      if (exists $Returns_num_things_changed{$call}) {
  
          # Some things return the number of things changed (like
          # chown, kill, chmod, etc). We only consider these successful
          # if *all* the things are changed.
  
          return qq[
              my \$num_things = \@_ - $Returns_num_things_changed{$call};
              my \$retval = $call(@argv);
  
              if (\$retval != \$num_things) {
  
                  # We need \$context to throw an exception.
                  # It's *always* set to scalar, because that's how
                  # autodie calls chown() above.
  
                  my \$context = "scalar";
                  $die;
              }
  
              return \$retval;
          ];
      }
  
      # AFAIK everything that can be given an unopned filehandle
      # will fail if it tries to use it, so we don't really need
      # the 'unopened' warning class here.  Especially since they
      # then report the wrong line number.
  
      # Other warnings are disabled because they produce excessive
      # complaints from smart-match hints under 5.10.1.
  
      my $code = qq[
          no warnings qw(unopened uninitialized numeric);
          no if \$\] >= 5.017011, warnings => "experimental::smartmatch";
  
          if (wantarray) {
              my \@results = $call(@argv);
              my \$retval  = \\\@results;
              my \$context = "list";
  
      ];
  
      my $retval_action = $Retval_action{$call} || '';
  
      if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
  
          # NB: Subroutine hints are passed as a full list.
          # This differs from the 5.10.0 smart-match behaviour,
          # but means that context unaware subroutines can use
          # the same hints in both list and scalar context.
  
          $code .= qq{
              if ( \$hints->{list}->(\@results) ) { $die };
          };
      }
      elsif ( PERL510 and $hints ) {
          $code .= qq{
              if ( \@results ~~ \$hints->{list} ) { $die };
          };
      }
      elsif ( $hints ) {
          croak sprintf(ERROR_58_HINTS, 'list', $sub);
      }
      else {
          $code .= qq{
              # An empty list, or a single undef is failure
              if (! \@results or (\@results == 1 and ! defined \$results[0])) {
                  $die;
              }
          }
      }
  
      # Tidy up the end of our wantarray call.
  
      $code .= qq[
              return \@results;
          }
      ];
  
  
      # Otherwise, we're in scalar context.
      # We're never in a void context, since we have to look
      # at the result.
  
      $code .= qq{
          my \$retval  = $call(@argv);
          my \$context = "scalar";
      };
  
      if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
  
          # We always call code refs directly, since that always
          # works in 5.8.x, and always works in 5.10.1
  
          return $code .= qq{
              if ( \$hints->{scalar}->(\$retval) ) { $die };
              $retval_action
              return \$retval;
          };
  
      }
      elsif (PERL510 and $hints) {
          return $code . qq{
  
              if ( \$retval ~~ \$hints->{scalar} ) { $die };
              $retval_action
              return \$retval;
          };
      }
      elsif ( $hints ) {
          croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
      }
  
      return $code .
      ( $use_defined_or ? qq{
  
          $die if not defined \$retval;
          $retval_action
          return \$retval;
  
      } : qq{
  
          $retval_action
          return \$retval || $die;
  
      } ) ;
  
  }
  
  # This returns the old copy of the sub, so we can
  # put it back at end of scope.
  
  # TODO : Check to make sure prototypes are restored correctly.
  
  # TODO: Taking a huge list of arguments is awful.  Rewriting to
  #       take a hash would be lovely.
  
  # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
  
  sub _make_fatal {
      my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
      my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
      my $ini = $sub;
  
      $sub = "${pkg}::$sub" unless $sub =~ /::/;
  
      # Figure if we're using lexical or package semantics and
      # twiddle the appropriate bits.
  
      if (not $lexical) {
          $Package_Fatal{$sub} = 1;
      }
  
      # TODO - We *should* be able to do skipping, since we know when
      # we've lexicalised / unlexicalised a subroutine.
  
      $name = $sub;
      $name =~ s/.*::// or $name =~ s/^&//;
  
      warn  "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
      croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
  
      if (defined(&$sub)) {   # user subroutine
  
          # NOTE: Previously we would localise $@ at this point, so
          # the following calls to eval {} wouldn't interfere with anything
          # that's already in $@.  Unfortunately, it would also stop
          # any of our croaks from triggering(!), which is even worse.
  
          # This could be something that we've fatalised that
          # was in core.
  
          if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
  
              # Something we previously made Fatal that was core.
              # This is safe to replace with an autodying to core
              # version.
  
              $core  = 1;
              $call  = "CORE::$name";
              $proto = prototype $call;
  
              # We return our $sref from this subroutine later
              # on, indicating this subroutine should be placed
              # back when we're finished.
  
              $sref = \&$sub;
  
          } else {
  
              # If this is something we've already fatalised or played with,
              # then look-up the name of the original sub for the rest of
              # our processing.
  
              $sub = $Is_fatalised_sub{\&$sub} || $sub;
  
              # A regular user sub, or a user sub wrapping a
              # core sub.
  
              $sref = \&$sub;
              $proto = prototype $sref;
              $call = '&$sref';
              require autodie::hints;
  
              $hints = autodie::hints->get_hints_for( $sref );
  
              # If we've insisted on hints, but don't have them, then
              # bail out!
  
              if ($insist and not $hints) {
                  croak(sprintf(ERROR_NOHINTS, $name));
              }
  
              # Otherwise, use the default hints if we don't have
              # any.
  
              $hints ||= autodie::hints::DEFAULT_HINTS();
  
          }
  
      } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
          # Stray user subroutine
          croak(sprintf(ERROR_NOTSUB,$sub));
  
      } elsif ($name eq 'system') {
  
          # If we're fatalising system, then we need to load
          # helper code.
  
          # The business with $E is to avoid clobbering our caller's
          # $@, and to avoid $@ being localised when we croak.
  
          my $E;
  
          {
              local $@;
  
              eval {
                  require IPC::System::Simple; # Only load it if we need it.
                  require autodie::exception::system;
              };
              $E = $@;
          }
  
          if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
  
          # Make sure we're using a recent version of ISS that actually
          # support fatalised system.
          if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
              croak sprintf(
              ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
              $IPC::System::Simple::VERSION
              );
          }
  
          $call = 'CORE::system';
          $name = 'system';
          $core = 1;
  
      } elsif ($name eq 'exec') {
          # Exec doesn't have a prototype.  We don't care.  This
          # breaks the exotic form with lexical scope, and gives
          # the regular form a "do or die" behavior as expected.
  
          $call = 'CORE::exec';
          $name = 'exec';
          $core = 1;
  
      } else {            # CORE subroutine
          my $E;
          {
              local $@;
              $proto = eval { prototype "CORE::$name" };
              $E = $@;
          }
          croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
          croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
          $core = 1;
          $call = "CORE::$name";
      }
  
      my $true_name = $core ? $call : $sub;
  
      # TODO: This caching works, but I don't like using $void and
      # $lexical as keys.  In particular, I suspect our code may end up
      # wrapping already wrapped code when autodie and Fatal are used
      # together.
  
      # NB: We must use '$sub' (the name plus package) and not
      # just '$name' (the short name) here.  Failing to do so
      # results code that's in the wrong package, and hence has
      # access to the wrong package filehandles.
  
      if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
          $class->_install_subs($pkg, { $name => $subref });
          return $sref;
      }
  
      # If our subroutine is reusable (ie, not package depdendent),
      # then check to see if we've got a cached copy, and use that.
      # See RT #46984. (Thanks to Niels Thykier for being awesome!)
  
      if ($core && exists $reusable_builtins{$call}) {
          # For non-lexical subs, we can just use this cache directly
          # - for lexical variants, we need a leak guard as well.
          $code = $reusable_builtins{$call}{$lexical};
          if (!$lexical && defined($code)) {
              $class->_install_subs($pkg, { $name => $code });
              return $sref;
          }
      }
  
      if (defined $proto) {
          $real_proto = " ($proto)";
      } else {
          $real_proto = '';
          $proto = '@';
      }
  
      if (!defined($code)) {
          # No code available, generate it now.
          my @protos = fill_protos($proto);
  
          $code = qq[
              sub$real_proto {
                local(\$", \$!) = (', ', 0);    # TODO - Why do we do this?
          ];
  
          # Don't have perl whine if exec fails, since we'll be handling
          # the exception now.
          $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
  
          $code .= $class->_write_invocation($core, $call, $name, $void, $lexical,
                                             $sub, $sref, @protos);
          $code .= "}\n";
          warn $code if $Debug;
  
          # I thought that changing package was a monumental waste of
          # time for CORE subs, since they'll always be the same.  However
          # that's not the case, since they may refer to package-based
          # filehandles (eg, with open).
          #
          # The %reusable_builtins hash defines ones we can aggressively
          # cache as they never depend upon package-based symbols.
  
          {
              no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
  
              my $E;
  
              {
                  local $@;
                  if (!exists($reusable_builtins{$call})) {
                      $code = eval("package $pkg; require Carp; $code");  ## no critic
                  } else {
                      $code = eval("require Carp; $code");  ## no critic
                      if (exists $reusable_builtins{$call}) {
                          # cache it so we don't recompile this part again
                          $reusable_builtins{$call}{$lexical} = $code;
                      }
                  }
                  $E = $@;
              }
  
              if (not $code) {
                  croak("Internal error in autodie/Fatal processing $true_name: $E");
  
              }
          }
      }
  
      # Now we need to wrap our fatalised sub inside an itty bitty
      # closure, which can detect if we've leaked into another file.
      # Luckily, we only need to do this for lexical (autodie)
      # subs.  Fatal subs can leak all they want, it's considered
      # a "feature" (or at least backwards compatible).
  
      # TODO: Cache our leak guards!
  
      # TODO: This is pretty hairy code.  A lot more tests would
      # be really nice for this.
  
      my $leak_guard;
  
      if ($lexical) {
          $leak_guard = _make_leak_guard($filename, $code, $sref, $call,
                                         $pkg, $proto, $real_proto);
      }
  
      my $installed_sub = $leak_guard || $code;
  
      $class->_install_subs($pkg, { $name => $installed_sub });
  
      $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
  
      # Cache that we've now overridden this sub.  If we get called
      # again, we may need to find that find subroutine again (eg, for hints).
  
      $Is_fatalised_sub{$installed_sub} = $sref;
  
      return $sref;
  
  }
  
  # This subroutine exists primarily so that child classes can override
  # it to point to their own exception class.  Doing this is significantly
  # less complex than overriding throw()
  
  sub exception_class { return "autodie::exception" };
  
  {
      my %exception_class_for;
      my %class_loaded;
  
      sub throw {
          my ($class, @args) = @_;
  
          # Find our exception class if we need it.
          my $exception_class =
               $exception_class_for{$class} ||= $class->exception_class;
  
          if (not $class_loaded{$exception_class}) {
              if ($exception_class =~ /[^\w:']/) {
                  confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
              }
  
              # Alas, Perl does turn barewords into modules unless they're
              # actually barewords.  As such, we're left doing a string eval
              # to make sure we load our file correctly.
  
              my $E;
  
              {
                  local $@;   # We can't clobber $@, it's wrong!
                  my $pm_file = $exception_class . ".pm";
                  $pm_file =~ s{ (?: :: | ' ) }{/}gx;
                  eval { require $pm_file };
                  $E = $@;    # Save $E despite ending our local.
              }
  
              # We need quotes around $@ to make sure it's stringified
              # while still in scope.  Without them, we run the risk of
              # $@ having been cleared by us exiting the local() block.
  
              confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
  
              $class_loaded{$exception_class}++;
  
          }
  
          return $exception_class->new(@args);
      }
  }
  
  # Creates and returns a leak guard (with prototype if needed).
  sub _make_leak_guard {
      my ($filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto, $real_proto) = @_;
  
      # The leak guard is rather lengthly (in fact it makes up the most
      # of _make_leak_guard).  It is possible to split it into a large
      # "generic" part and a small wrapper with call-specific
      # information.  This was done in v2.19 and profiling suggested
      # that we ended up using a substantial amount of runtime in "goto"
      # between the leak guard(s) and the final sub.  Therefore, the two
      # parts were merged into one to reduce the runtime overhead.
  
      my $leak_guard = sub {
          my $caller_level = 0;
          my $caller;
  
          while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) {
  
              # If our filename is actually an eval, and we
              # reach it, then go to our autodying code immediatately.
  
              last if ($caller eq $filename);
              $caller_level++;
          }
  
          # We're now out of the eval stack.
  
          if ($caller eq $filename) {
              # No leak, call the wrapper.  NB: In this case, it doesn't
              # matter if it is a CORE sub or not.
              goto $wrapped_sub;
          }
  
          # We leaked, time to call the original function.
          # - for non-core functions that will be $orig_sub
          goto $orig_sub if defined($orig_sub);
  
          # We are wrapping a CORE sub
  
          # If we've cached a trampoline, then use it.
          my $trampoline_sub = $Trampoline_cache{$pkg}{$call};
  
          if (not $trampoline_sub) {
              # If we don't have a trampoline, we need to build it.
              #
              # We only generate trampolines when we need them, and
              # we can cache them by subroutine + package.
  
              # TODO: Consider caching on reusable_builtins status as well.
  
              $trampoline_sub = _make_core_trampoline($call, $pkg, $proto);
  
              # Let's cache that, so we don't have to do it again.
              $Trampoline_cache{$pkg}{$call} = $trampoline_sub;
          }
  
          # Bounce to our trampoline, which takes us to our core sub.
          goto \&$trampoline_sub;
      };  # <-- end of leak guard
  
      # If there is a prototype on the original sub, copy it to the leak
      # guard.
      if ($real_proto ne '') {
          # The "\&" may appear to be redundant but set_prototype
          # croaks when it is removed.
          set_prototype(\&$leak_guard, $proto);
      }
  
      return $leak_guard;
  }
  
  # Create a trampoline for calling a core sub.  Essentially, a tiny sub
  # that figures out how we should be calling our core sub, puts in the
  # arguments in the right way, and bounces our control over to it.
  #
  # If we could use `goto &` on core builtins, we wouldn't need this.
  sub _make_core_trampoline {
      my ($call, $pkg, $proto_str) = @_;
      my $trampoline_code = 'sub {';
      my $trampoline_sub;
      my @protos = fill_protos($proto_str);
  
      # TODO: It may be possible to combine this with write_invocation().
  
      foreach my $proto (@protos) {
          local $" = ", ";    # So @args is formatted correctly.
          my ($count, @args) = @$proto;
          if (@args && $args[-1] =~ m/[@#]_/) {
              $trampoline_code .= qq/
                  if (\@_ >= $count) {
                      return $call(@args);
                  }
               /;
          } else {
              $trampoline_code .= qq<
                  if (\@_ == $count) {
                      return $call(@args);
                  }
               >;
          }
      }
  
      $trampoline_code .= qq< Carp::croak("Internal error in Fatal/autodie.  Leak-guard failure"); } >;
      my $E;
  
      {
          local $@;
          $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic
          $E = $@;
      }
      die "Internal error in Fatal/autodie: Leak-guard installation failure: $E"
          if $E;
  
      return $trampoline_sub;
  }
  
  # For some reason, dying while replacing our subs doesn't
  # kill our calling program.  It simply stops the loading of
  # autodie and keeps going with everything else.  The _autocroak
  # sub allows us to die with a vengeance.  It should *only* ever be
  # used for serious internal errors, since the results of it can't
  # be captured.
  
  sub _autocroak {
      warn Carp::longmess(@_);
      exit(255);  # Ugh!
  }
  
  package autodie::Scope::Guard;
  
  # This code schedules the cleanup of subroutines at the end of
  # scope.  It's directly inspired by chocolateboy's excellent
  # Scope::Guard module.
  
  sub new {
      my ($class, $handler) = @_;
  
      return bless $handler, $class;
  }
  
  sub DESTROY {
      my ($self) = @_;
  
      $self->();
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Fatal - Replace functions with equivalents which succeed or die
  
  =head1 SYNOPSIS
  
      use Fatal qw(open close);
  
      open(my $fh, "<", $filename);  # No need to check errors!
  
      use File::Copy qw(move);
      use Fatal qw(move);
  
      move($file1, $file2); # No need to check errors!
  
      sub juggle { . . . }
      Fatal->import('juggle');
  
  =head1 BEST PRACTICE
  
  B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
  L<autodie> in preference to C<Fatal>.  L<autodie> supports lexical scoping,
  throws real exception objects, and provides much nicer error messages.
  
  The use of C<:void> with Fatal is discouraged.
  
  =head1 DESCRIPTION
  
  C<Fatal> provides a way to conveniently replace
  functions which normally return a false value when they fail with
  equivalents which raise exceptions if they are not successful.  This
  lets you use these functions without having to test their return
  values explicitly on each call.  Exceptions can be caught using
  C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
  
  The do-or-die equivalents are set up simply by calling Fatal's
  C<import> routine, passing it the names of the functions to be
  replaced.  You may wrap both user-defined functions and overridable
  CORE operators (except C<exec>, C<system>, C<print>, or any other
  built-in that cannot be expressed via prototypes) in this way.
  
  If the symbol C<:void> appears in the import list, then functions
  named later in that import list raise an exception only when
  these are called in void context--that is, when their return
  values are ignored.  For example
  
      use Fatal qw/:void open close/;
  
      # properly checked, so no exception raised on error
      if (not open(my $fh, '<', '/bogotic') {
          warn "Can't open /bogotic: $!";
      }
  
      # not checked, so error raises an exception
      close FH;
  
  The use of C<:void> is discouraged, as it can result in exceptions
  not being thrown if you I<accidentally> call a method without
  void context.  Use L<autodie> instead if you need to be able to
  disable autodying/Fatal behaviour for a small block of code.
  
  =head1 DIAGNOSTICS
  
  =over 4
  
  =item Bad subroutine name for Fatal: %s
  
  You've called C<Fatal> with an argument that doesn't look like
  a subroutine name, nor a switch that this version of Fatal
  understands.
  
  =item %s is not a Perl subroutine
  
  You've asked C<Fatal> to try and replace a subroutine which does not
  exist, or has not yet been defined.
  
  =item %s is neither a builtin, nor a Perl subroutine
  
  You've asked C<Fatal> to replace a subroutine, but it's not a Perl
  built-in, and C<Fatal> couldn't find it as a regular subroutine.
  It either doesn't exist or has not yet been defined.
  
  =item Cannot make the non-overridable %s fatal
  
  You've tried to use C<Fatal> on a Perl built-in that can't be
  overridden, such as C<print> or C<system>, which means that
  C<Fatal> can't help you, although some other modules might.
  See the L</"SEE ALSO"> section of this documentation.
  
  =item Internal error: %s
  
  You've found a bug in C<Fatal>.  Please report it using
  the C<perlbug> command.
  
  =back
  
  =head1 BUGS
  
  C<Fatal> clobbers the context in which a function is called and always
  makes it a scalar context, except when the C<:void> tag is used.
  This problem does not exist in L<autodie>.
  
  "Used only once" warnings can be generated when C<autodie> or C<Fatal>
  is used with package filehandles (eg, C<FILE>).  It's strongly recommended
  you use scalar filehandles instead.
  
  =head1 AUTHOR
  
  Original module by Lionel Cons (CERN).
  
  Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
  
  L<autodie> support, bugfixes, extended diagnostics, C<system>
  support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
  
  =head1 LICENSE
  
  This module is free software, you may distribute it under the
  same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<autodie> for a nicer way to use lexical Fatal.
  
  L<IPC::System::Simple> for a similar idea for calls to C<system()>
  and backticks.
  
  =for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation
  
  =cut
FATAL

$fatpacked{"File/chdir.pm"} = <<'FILE_CHDIR';
  package File::chdir;
  use 5.004;
  use strict;
  use vars qw($VERSION @ISA @EXPORT $CWD @CWD);
  # ABSTRACT: a more sensible way to change directories
  our $VERSION = '0.1008'; # VERSION
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(*CWD);
  
  use Carp;
  use Cwd 3.16;
  use File::Spec::Functions 3.27 qw/canonpath splitpath catpath splitdir catdir/;
  
  tie $CWD, 'File::chdir::SCALAR' or die "Can't tie \$CWD";
  tie @CWD, 'File::chdir::ARRAY'  or die "Can't tie \@CWD";
  
  sub _abs_path {
      # Otherwise we'll never work under taint mode.
      my($cwd) = Cwd::getcwd =~ /(.*)/s;
      # Run through File::Spec, since everything else uses it
      return canonpath($cwd);
  }
  
  # splitpath but also split directory
  sub _split_cwd {
      my ($vol, $dir) = splitpath(_abs_path, 1);
      my @dirs = splitdir( $dir );
      shift @dirs; # get rid of leading empty "root" directory
      return ($vol, @dirs);
  }
  
  # catpath, but take list of directories
  # restore the empty root dir and provide an empty file to avoid warnings
  sub _catpath {
      my ($vol, @dirs) = @_;
      return catpath($vol, catdir(q{}, @dirs), q{});
  }
  
  sub _chdir {
      # Untaint target directory
      my ($new_dir) = $_[0] =~ /(.*)/s;
  
      local $Carp::CarpLevel = $Carp::CarpLevel + 1;
      if ( ! CORE::chdir($new_dir) ) {
          croak "Failed to change directory to '$new_dir': $!";
      };
      return 1;
  }
  
  {
      package File::chdir::SCALAR;
      use Carp;
  
      BEGIN {
          *_abs_path = \&File::chdir::_abs_path;
          *_chdir = \&File::chdir::_chdir;
          *_split_cwd = \&File::chdir::_split_cwd;
          *_catpath = \&File::chdir::_catpath;
      }
  
      sub TIESCALAR {
          bless [], $_[0];
      }
  
      # To be safe, in case someone chdir'd out from under us, we always
      # check the Cwd explicitly.
      sub FETCH {
          return _abs_path;
      }
  
      sub STORE {
          return unless defined $_[1];
          _chdir($_[1]);
      }
  }
  
  
  {
      package File::chdir::ARRAY;
      use Carp;
  
      BEGIN {
          *_abs_path = \&File::chdir::_abs_path;
          *_chdir = \&File::chdir::_chdir;
          *_split_cwd = \&File::chdir::_split_cwd;
          *_catpath = \&File::chdir::_catpath;
      }
  
      sub TIEARRAY {
          bless {}, $_[0];
      }
  
      sub FETCH {
          my($self, $idx) = @_;
          my ($vol, @cwd) = _split_cwd;
          return $cwd[$idx];
      }
  
      sub STORE {
          my($self, $idx, $val) = @_;
  
          my ($vol, @cwd) = _split_cwd;
          if( $self->{Cleared} ) {
              @cwd = ();
              $self->{Cleared} = 0;
          }
  
          $cwd[$idx] = $val;
          my $dir = _catpath($vol,@cwd);
  
          _chdir($dir);
          return $cwd[$idx];
      }
  
      sub FETCHSIZE {
          my ($vol, @cwd) = _split_cwd;
          return scalar @cwd;
      }
      sub STORESIZE {}
  
      sub PUSH {
          my($self) = shift;
  
          my $dir = _catpath(_split_cwd, @_);
          _chdir($dir);
          return $self->FETCHSIZE;
      }
  
      sub POP {
          my($self) = shift;
  
          my ($vol, @cwd) = _split_cwd;
          my $popped = pop @cwd;
          my $dir = _catpath($vol,@cwd);
          _chdir($dir);
          return $popped;
      }
  
      sub SHIFT {
          my($self) = shift;
  
          my ($vol, @cwd) = _split_cwd;
          my $shifted = shift @cwd;
          my $dir = _catpath($vol,@cwd);
          _chdir($dir);
          return $shifted;
      }
  
      sub UNSHIFT {
          my($self) = shift;
  
          my ($vol, @cwd) = _split_cwd;
          my $dir = _catpath($vol, @_, @cwd);
          _chdir($dir);
          return $self->FETCHSIZE;
      }
  
      sub CLEAR  {
          my($self) = shift;
          $self->{Cleared} = 1;
      }
  
      sub SPLICE {
          my $self = shift;
          my $offset = shift || 0;
          my $len = shift || $self->FETCHSIZE - $offset;
          my @new_dirs = @_;
  
          my ($vol, @cwd) = _split_cwd;
          my @orig_dirs = splice @cwd, $offset, $len, @new_dirs;
          my $dir = _catpath($vol, @cwd);
          _chdir($dir);
          return @orig_dirs;
      }
  
      sub EXTEND { }
      sub EXISTS {
          my($self, $idx) = @_;
          return $self->FETCHSIZE >= $idx ? 1 : 0;
      }
  
      sub DELETE {
          my($self, $idx) = @_;
          croak "Can't delete except at the end of \@CWD"
              if $idx < $self->FETCHSIZE - 1;
          local $Carp::CarpLevel = $Carp::CarpLevel + 1;
          $self->POP;
      }
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  File::chdir - a more sensible way to change directories
  
  =head1 VERSION
  
  version 0.1008
  
  =head1 SYNOPSIS
  
     use File::chdir;
   
     $CWD = "/foo/bar";     # now in /foo/bar
     {
         local $CWD = "/moo/baz";  # now in /moo/baz
         ...
     }
   
     # still in /foo/bar!
  
  =head1 DESCRIPTION
  
  Perl's C<<< chdir() >>> has the unfortunate problem of being very, very, very
  global.  If any part of your program calls C<<< chdir() >>> or if any library
  you use calls C<<< chdir() >>>, it changes the current working directory for
  the B<whole> program.
  
  This sucks.
  
  File::chdir gives you an alternative, C<<< $CWD >>> and C<<< @CWD >>>.  These two
  variables combine all the power of C<<< chdir() >>>, L<File::Spec> and L<Cwd>.
  
  =head1 $CWD
  
  Use the C<<< $CWD >>> variable instead of C<<< chdir() >>> and Cwd.
  
       use File::chdir;
       $CWD = $dir;  # just like chdir($dir)!
       print $CWD;   # prints the current working directory
  
  It can be localized, and it does the right thing.
  
       $CWD = "/foo";      # it's /foo out here.
       {
           local $CWD = "/bar";  # /bar in here
       }
       # still /foo out here!
  
  C<<< $CWD >>> always returns the absolute path in the native form for the
  operating system.
  
  C<<< $CWD >>> and normal C<<< chdir() >>> work together just fine.
  
  =head1 @CWD
  
  C<<< @CWD >>> represents the current working directory as an array, each
  directory in the path is an element of the array.  This can often make
  the directory easier to manipulate, and you don't have to fumble with
  C<<< File::Spec->splitpath >>> and C<<< File::Spec->catdir >>> to make portable code.
  
     # Similar to chdir("/usr/local/src/perl")
     @CWD = qw(usr local src perl);
  
  pop, push, shift, unshift and splice all work.  pop and push are
  probably the most useful.
  
     pop @CWD;                 # same as chdir(File::Spec->updir)
     push @CWD, 'some_dir'     # same as chdir('some_dir')
  
  C<<< @CWD >>> and C<<< $CWD >>> both work fine together.
  
  B<NOTE> Due to a perl bug you can't localize C<<< @CWD >>>.  See L</CAVEATS> for a work around.
  
  =head1 EXAMPLES
  
  (We omit the C<<< use File::chdir >>> from these examples for terseness)
  
  Here's C<<< $CWD >>> instead of C<<< chdir() >>>:
  
       $CWD = 'foo';           # chdir('foo')
  
  and now instead of Cwd.
  
       print $CWD;             # use Cwd;  print Cwd::abs_path
  
  you can even do zsh style C<<< cd foo bar >>>
  
       $CWD = '/usr/local/foo';
       $CWD =~ s/usr/var/;
  
  if you want to localize that, make sure you get the parens right
  
       {
           (local $CWD) =~ s/usr/var/;
           ...
       }
  
  It's most useful for writing polite subroutines which don't leave the
  program in some strange directory:
  
       sub foo {
           local $CWD = 'some/other/dir';
           ...do your work...
       }
  
  which is much simpler than the equivalent:
  
       sub foo {
           use Cwd;
           my $orig_dir = Cwd::getcwd;
           chdir('some/other/dir');
   
           ...do your work...
   
           chdir($orig_dir);
       }
  
  C<<< @CWD >>> comes in handy when you want to start moving up and down the
  directory hierarchy in a cross-platform manner without having to use
  File::Spec.
  
       pop @CWD;                   # chdir(File::Spec->updir);
       push @CWD, 'some', 'dir'    # chdir(File::Spec->catdir(qw(some dir)));
  
  You can easily change your parent directory:
  
       # chdir from /some/dir/bar/moo to /some/dir/foo/moo
       $CWD[-2] = 'foo';
  
  =head1 CAVEATS
  
  =head3 C<<< local @CWD >>> does not work.
  
  C<<< local @CWD >>> will not localize C<<< @CWD >>>.  This is a bug in Perl, you
  can't localize tied arrays.  As a work around localizing $CWD will
  effectively localize @CWD.
  
       {
           local $CWD;
           pop @CWD;
           ...
       }
  
  =head3 Assigning to C<<< @CWD >>> calls C<<< chdir() >>> for each element
  
       @CWD = qw/a b c d/;
  
  Internally, Perl clears C<<< @CWD >>> and assigns each element in turn.  Thus, this
  code above will do this:
  
       chdir 'a';
       chdir 'a/b';
       chdir 'a/b/c';
       chdir 'a/b/c/d';
  
  Generally, avoid assigning to C<<< @CWD >>> and just use push and pop instead.
  
  =head3 Volumes not handled
  
  There is currently no way to change the current volume via File::chdir.
  
  =head1 NOTES
  
  C<<< $CWD >>> returns the current directory using native path separators, i.e. \
  on Win32.  This ensures that C<<< $CWD >>> will compare correctly with directories
  created using File::Spec.  For example:
  
       my $working_dir = File::Spec->catdir( $CWD, "foo" );
       $CWD = $working_dir;
       doing_stuff_might_chdir();
       is( $CWD, $working_dir, "back to original working_dir?" );
  
  Deleting the last item of C<<< @CWD >>> will act like a pop.  Deleting from the
  middle will throw an exception.
  
       delete @CWD[-1]; # OK
       delete @CWD[-2]; # Dies
  
  What should %CWD do?  Something with volumes?
  
       # chdir to C:\Program Files\Sierra\Half Life ?
       $CWD{C} = '\\Program Files\\Sierra\\Half Life';
  
  =head1 DIAGNOSTICS
  
  If an error is encountered when changing C<<< $CWD >>> or C<<< @CWD >>>, one of
  the following exceptions will be thrown:
  
  =over
  
  =item *
  
  I<Can't delete except at the end of @CWD>
  
  =item *
  
  I<Failed to change directory to '$dir'>
  
  =back
  
  =head1 HISTORY
  
  Michael wanted C<<< local chdir >>> to work.  p5p didn't.  But it wasn't over!
  Was it over when the Germans bombed Pearl Harbor?  Hell, no!
  
  Abigail andE<sol>or Bryan Warnock suggested the C<<< $CWD >>> thing (Michael forgets
  which).  They were right.
  
  The C<<< chdir() >>> override was eliminated in 0.04.
  
  David became co-maintainer with 0.06_01 to fix some chronic
  Win32 path bugs.
  
  As of 0.08, if changing C<<< $CWD >>> or C<<< @CWD >>> fails to change the directory, an
  error will be thrown.
  
  =head1 SEE ALSO
  
  L<File::pushd>, L<File::Spec>, L<Cwd>, L<perlfunc/chdir>,
  "Animal House" L<http://www.imdb.com/title/tt0077975/quotes>
  
  =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://rt.cpan.org/Public/Dist/Display.html?Name=File-chdir>.
  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-chdir>
  
    git clone git://github.com/dagolden/file-chdir.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  David A Golden <dagolden@cpan.org>
  
  =item *
  
  Michael G Schwern <schwern@pobox.com> (original author)
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2012 by Michael G Schwern and David A 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
FILE_CHDIR

$fatpacked{"HTTP/Config.pm"} = <<'HTTP_CONFIG';
  package HTTP::Config;
  
  use strict;
  use URI;
  use vars qw($VERSION);
  
  $VERSION = "6.00";
  
  sub new {
      my $class = shift;
      return bless [], $class;
  }
  
  sub entries {
      my $self = shift;
      @$self;
  }
  
  sub empty {
      my $self = shift;
      not @$self;
  }
  
  sub add {
      if (@_ == 2) {
          my $self = shift;
          push(@$self, shift);
          return;
      }
      my($self, %spec) = @_;
      push(@$self, \%spec);
      return;
  }
  
  sub find2 {
      my($self, %spec) = @_;
      my @found;
      my @rest;
   ITEM:
      for my $item (@$self) {
          for my $k (keys %spec) {
              if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
                  push(@rest, $item);
                  next ITEM;
              }
          }
          push(@found, $item);
      }
      return \@found unless wantarray;
      return \@found, \@rest;
  }
  
  sub find {
      my $self = shift;
      my $f = $self->find2(@_);
      return @$f if wantarray;
      return $f->[0];
  }
  
  sub remove {
      my($self, %spec) = @_;
      my($removed, $rest) = $self->find2(%spec);
      @$self = @$rest if @$removed;
      return @$removed;
  }
  
  my %MATCH = (
      m_scheme => sub {
          my($v, $uri) = @_;
          return $uri->_scheme eq $v;  # URI known to be canonical
      },
      m_secure => sub {
          my($v, $uri) = @_;
          my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
          return $secure == !!$v;
      },
      m_host_port => sub {
          my($v, $uri) = @_;
          return unless $uri->can("host_port");
          return $uri->host_port eq $v, 7;
      },
      m_host => sub {
          my($v, $uri) = @_;
          return unless $uri->can("host");
          return $uri->host eq $v, 6;
      },
      m_port => sub {
          my($v, $uri) = @_;
          return unless $uri->can("port");
          return $uri->port eq $v;
      },
      m_domain => sub {
          my($v, $uri) = @_;
          return unless $uri->can("host");
          my $h = $uri->host;
          $h = "$h.local" unless $h =~ /\./;
          $v = ".$v" unless $v =~ /^\./;
          return length($v), 5 if substr($h, -length($v)) eq $v;
          return 0;
      },
      m_path => sub {
          my($v, $uri) = @_;
          return unless $uri->can("path");
          return $uri->path eq $v, 4;
      },
      m_path_prefix => sub {
          my($v, $uri) = @_;
          return unless $uri->can("path");
          my $path = $uri->path;
          my $len = length($v);
          return $len, 3 if $path eq $v;
          return 0 if length($path) <= $len;
          $v .= "/" unless $v =~ m,/\z,,;
          return $len, 3 if substr($path, 0, length($v)) eq $v;
          return 0;
      },
      m_path_match => sub {
          my($v, $uri) = @_;
          return unless $uri->can("path");
          return $uri->path =~ $v;
      },
      m_uri__ => sub {
          my($v, $k, $uri) = @_;
          return unless $uri->can($k);
          return 1 unless defined $v;
          return $uri->$k eq $v;
      },
      m_method => sub {
          my($v, $uri, $request) = @_;
          return $request && $request->method eq $v;
      },
      m_proxy => sub {
          my($v, $uri, $request) = @_;
          return $request && ($request->{proxy} || "") eq $v;
      },
      m_code => sub {
          my($v, $uri, $request, $response) = @_;
          $v =~ s/xx\z//;
          return unless $response;
          return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
      },
      m_media_type => sub {  # for request too??
          my($v, $uri, $request, $response) = @_;
          return unless $response;
          return 1, 1 if $v eq "*/*";
          my $ct = $response->content_type;
          return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
          return 3, 1 if $v eq "html" && $response->content_is_html;
          return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
          return 10, 1 if $v eq $ct;
          return 0;
      },
      m_header__ => sub {
          my($v, $k, $uri, $request, $response) = @_;
          return unless $request;
          return 1 if $request->header($k) eq $v;
          return 1 if $response && $response->header($k) eq $v;
          return 0;
      },
      m_response_attr__ => sub {
          my($v, $k, $uri, $request, $response) = @_;
          return unless $response;
          return 1 if !defined($v) && exists $response->{$k};
          return 0 unless exists $response->{$k};
          return 1 if $response->{$k} eq $v;
          return 0;
      },
  );
  
  sub matching {
      my $self = shift;
      if (@_ == 1) {
          if ($_[0]->can("request")) {
              unshift(@_, $_[0]->request);
              unshift(@_, undef) unless defined $_[0];
          }
          unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
      }
      my($uri, $request, $response) = @_;
      $uri = URI->new($uri) unless ref($uri);
  
      my @m;
   ITEM:
      for my $item (@$self) {
          my $order;
          for my $ikey (keys %$item) {
              my $mkey = $ikey;
              my $k;
              $k = $1 if $mkey =~ s/__(.*)/__/;
              if (my $m = $MATCH{$mkey}) {
                  #print "$ikey $mkey\n";
                  my($c, $o);
                  my @arg = (
                      defined($k) ? $k : (),
                      $uri, $request, $response
                  );
                  my $v = $item->{$ikey};
                  $v = [$v] unless ref($v) eq "ARRAY";
                  for (@$v) {
                      ($c, $o) = $m->($_, @arg);
                      #print "  - $_ ==> $c $o\n";
                      last if $c;
                  }
                  next ITEM unless $c;
                  $order->[$o || 0] += $c;
              }
          }
          $order->[7] ||= 0;
          $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
          push(@m, $item);
      }
      @m = sort { $b->{_order} cmp $a->{_order} } @m;
      delete $_->{_order} for @m;
      return @m if wantarray;
      return $m[0];
  }
  
  sub add_item {
      my $self = shift;
      my $item = shift;
      return $self->add(item => $item, @_);
  }
  
  sub remove_items {
      my $self = shift;
      return map $_->{item}, $self->remove(@_);
  }
  
  sub matching_items {
      my $self = shift;
      return map $_->{item}, $self->matching(@_);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Config - Configuration for request and response objects
  
  =head1 SYNOPSIS
  
   use HTTP::Config;
   my $c = HTTP::Config->new;
   $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
   
   use HTTP::Request;
   my $request = HTTP::Request->new(GET => "http://www.example.com");
   
   if (my @m = $c->matching($request)) {
      print "Yadayada\n" if $m[0]->{verbose};
   }
  
  =head1 DESCRIPTION
  
  An C<HTTP::Config> object is a list of entries that
  can be matched against request or request/response pairs.  Its
  purpose is to hold configuration data that can be looked up given a
  request or response object.
  
  Each configuration entry is a hash.  Some keys specify matching to
  occur against attributes of request/response objects.  Other keys can
  be used to hold user data.
  
  The following methods are provided:
  
  =over 4
  
  =item $conf = HTTP::Config->new
  
  Constructs a new empty C<HTTP::Config> object and returns it.
  
  =item $conf->entries
  
  Returns the list of entries in the configuration object.
  In scalar context returns the number of entries.
  
  =item $conf->empty
  
  Return true if there are no entries in the configuration object.
  This is just a shorthand for C<< not $conf->entries >>.
  
  =item $conf->add( %matchspec, %other )
  
  =item $conf->add( \%entry )
  
  Adds a new entry to the configuration.
  You can either pass separate key/value pairs or a hash reference.
  
  =item $conf->remove( %spec )
  
  Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
  If %spec is empty this will match all entries; so it will empty the configuation object.
  
  =item $conf->matching( $uri, $request, $response )
  
  =item $conf->matching( $uri )
  
  =item $conf->matching( $request )
  
  =item $conf->matching( $response )
  
  Returns the entries that match the given $uri, $request and $response triplet.
  
  If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
  If called with a single $response object, then the request object is obtained by calling its 'request' method;
  and then the $uri is obtained as if a single $request was provided.
  
  The entries are returned with the most specific matches first.
  In scalar context returns the most specific match or C<undef> in none match.
  
  =item $conf->add_item( $item, %matchspec )
  
  =item $conf->remove_items( %spec )
  
  =item $conf->matching_items( $uri, $request, $response )
  
  Wrappers that hides the entries themselves.
  
  =back
  
  =head2 Matching
  
  The following keys on a configuration entry specify matching.  For all
  of these you can provide an array of values instead of a single value.
  The entry matches if at least one of the values in the array matches.
  
  Entries that require match against a response object attribute will never match
  unless a response object was provided.
  
  =over
  
  =item m_scheme => $scheme
  
  Matches if the URI uses the specified scheme; e.g. "http".
  
  =item m_secure => $bool
  
  If $bool is TRUE; matches if the URI uses a secure scheme.  If $bool
  is FALSE; matches if the URI does not use a secure scheme.  An example
  of a secure scheme is "https".
  
  =item m_host_port => "$hostname:$port"
  
  Matches if the URI's host_port method return the specified value.
  
  =item m_host => $hostname
  
  Matches if the URI's host method returns the specified value.
  
  =item m_port => $port
  
  Matches if the URI's port method returns the specified value.
  
  =item m_domain => ".$domain"
  
  Matches if the URI's host method return a value that within the given
  domain.  The hostname "www.example.com" will for instance match the
  domain ".com".
  
  =item m_path => $path
  
  Matches if the URI's path method returns the specified value.
  
  =item m_path_prefix => $path
  
  Matches if the URI's path is the specified path or has the specified
  path as prefix.
  
  =item m_path_match => $Regexp
  
  Matches if the regular expression matches the URI's path.  Eg. qr/\.html$/.
  
  =item m_method => $method
  
  Matches if the request method matches the specified value. Eg. "GET" or "POST".
  
  =item m_code => $digit
  
  =item m_code => $status_code
  
  Matches if the response status code matches.  If a single digit is
  specified; matches for all response status codes beginning with that digit.
  
  =item m_proxy => $url
  
  Matches if the request is to be sent to the given Proxy server.
  
  =item m_media_type => "*/*"
  
  =item m_media_type => "text/*"
  
  =item m_media_type => "html"
  
  =item m_media_type => "xhtml"
  
  =item m_media_type => "text/html"
  
  Matches if the response media type matches.
  
  With a value of "html" matches if $response->content_is_html returns TRUE.
  With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
  
  =item m_uri__I<$method> => undef
  
  Matches if the URI object provides the method.
  
  =item m_uri__I<$method> => $string
  
  Matches if the URI's $method method returns the given value.
  
  =item m_header__I<$field> => $string
  
  Matches if either the request or the response have a header $field with the given value.
  
  =item m_response_attr__I<$key> => undef
  
  =item m_response_attr__I<$key> => $string
  
  Matches if the response object has that key, or the entry has the given value.
  
  =back
  
  =head1 SEE ALSO
  
  L<URI>, L<HTTP::Request>, L<HTTP::Response>
  
  =head1 COPYRIGHT
  
  Copyright 2008, Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
HTTP_CONFIG

$fatpacked{"HTTP/Date.pm"} = <<'HTTP_DATE';
  package HTTP::Date;
  
  $VERSION = "6.02";
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(time2str str2time);
  @EXPORT_OK = qw(parse_date time2iso time2isoz);
  
  use strict;
  require Time::Local;
  
  use vars qw(@DoW @MoY %MoY);
  @DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
  @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  @MoY{@MoY} = (1..12);
  
  my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1);
  
  
  sub time2str (;$)
  {
      my $time = shift;
      $time = time unless defined $time;
      my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
      sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
  	    $DoW[$wday],
  	    $mday, $MoY[$mon], $year+1900,
  	    $hour, $min, $sec);
  }
  
  
  sub str2time ($;$)
  {
      my $str = shift;
      return undef unless defined $str;
  
      # fast exit for strictly conforming string
      if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) {
  	return eval {
  	    my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3);
  	    $t < 0 ? undef : $t;
  	};
      }
  
      my @d = parse_date($str);
      return undef unless @d;
      $d[1]--;        # month
  
      my $tz = pop(@d);
      unless (defined $tz) {
  	unless (defined($tz = shift)) {
  	    return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
  			  my $t = Time::Local::timelocal(reverse @d) + $frac;
  			  $t < 0 ? undef : $t;
  		        };
  	}
      }
  
      my $offset = 0;
      if ($GMT_ZONE{uc $tz}) {
  	# offset already zero
      }
      elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) {
  	$offset = 3600 * $2;
  	$offset += 60 * $3 if $3;
  	$offset *= -1 if $1 && $1 eq '-';
      }
      else {
  	eval { require Time::Zone } || return undef;
  	$offset = Time::Zone::tz_offset($tz);
  	return undef unless defined $offset;
      }
  
      return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
  		  my $t = Time::Local::timegm(reverse @d) + $frac;
  		  $t < 0 ? undef : $t - $offset;
  		};
  }
  
  
  sub parse_date ($)
  {
      local($_) = shift;
      return unless defined;
  
      # More lax parsing below
      s/^\s+//;  # kill leading space
      s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
  
      my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm);
  
      # Then we are able to check for most of the formats with this regexp
      (($day,$mon,$yr,$hr,$min,$sec,$tz) =
          /^
  	 (\d\d?)               # day
  	    (?:\s+|[-\/])
  	 (\w+)                 # month
  	    (?:\s+|[-\/])
  	 (\d+)                 # year
  	 (?:
  	       (?:\s+|:)       # separator before clock
  	    (\d\d?):(\d\d)     # hour:min
  	    (?::(\d\d))?       # optional seconds
  	 )?                    # optional clock
  	    \s*
  	 ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
  	    \s*
  	 (?:\(\w+\)|\w{3,})?   # ASCII representation of timezone.
  	    \s*$
  	/x)
  
      ||
  
      # Try the ctime and asctime format
      (($mon, $day, $hr, $min, $sec, $tz, $yr) =
  	/^
  	 (\w{1,3})             # month
  	    \s+
  	 (\d\d?)               # day
  	    \s+
  	 (\d\d?):(\d\d)        # hour:min
  	 (?::(\d\d))?          # optional seconds
  	    \s+
  	 (?:([A-Za-z]+)\s+)?   # optional timezone
  	 (\d+)                 # year
  	    \s*$               # allow trailing whitespace
  	/x)
  
      ||
  
      # Then the Unix 'ls -l' date format
      (($mon, $day, $yr, $hr, $min, $sec) =
  	/^
  	 (\w{3})               # month
  	    \s+
  	 (\d\d?)               # day
  	    \s+
  	 (?:
  	    (\d\d\d\d) |       # year
  	    (\d{1,2}):(\d{2})  # hour:min
              (?::(\d\d))?       # optional seconds
  	 )
  	 \s*$
         /x)
  
      ||
  
      # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
      (($yr, $mon, $day, $hr, $min, $sec, $tz) =
  	/^
  	  (\d{4})              # year
  	     [-\/]?
  	  (\d\d?)              # numerical month
  	     [-\/]?
  	  (\d\d?)              # day
  	 (?:
  	       (?:\s+|[-:Tt])  # separator before clock
  	    (\d\d?):?(\d\d)    # hour:min
  	    (?::?(\d\d(?:\.\d*)?))?  # optional seconds (and fractional)
  	 )?                    # optional clock
  	    \s*
  	 ([-+]?\d\d?:?(:?\d\d)?
  	  |Z|z)?               # timezone  (Z is "zero meridian", i.e. GMT)
  	    \s*$
  	/x)
  
      ||
  
      # Windows 'dir' 11-12-96  03:52PM
      (($mon, $day, $yr, $hr, $min, $ampm) =
          /^
            (\d{2})                # numerical month
               -
            (\d{2})                # day
               -
            (\d{2})                # year
               \s+
            (\d\d?):(\d\d)([APap][Mm])  # hour:min AM or PM
               \s*$
          /x)
  
      ||
      return;  # unrecognized format
  
      # Translate month name to number
      $mon = $MoY{$mon} ||
             $MoY{"\u\L$mon"} ||
  	   ($mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon)) ||
             return;
  
      # If the year is missing, we assume first date before the current,
      # because of the formats we support such dates are mostly present
      # on "ls -l" listings.
      unless (defined $yr) {
  	my $cur_mon;
  	($cur_mon, $yr) = (localtime)[4, 5];
  	$yr += 1900;
  	$cur_mon++;
  	$yr-- if $mon > $cur_mon;
      }
      elsif (length($yr) < 3) {
  	# Find "obvious" year
  	my $cur_yr = (localtime)[5] + 1900;
  	my $m = $cur_yr % 100;
  	my $tmp = $yr;
  	$yr += $cur_yr - $m;
  	$m -= $tmp;
  	$yr += ($m > 0) ? 100 : -100
  	    if abs($m) > 50;
      }
  
      # Make sure clock elements are defined
      $hr  = 0 unless defined($hr);
      $min = 0 unless defined($min);
      $sec = 0 unless defined($sec);
  
      # Compensate for AM/PM
      if ($ampm) {
  	$ampm = uc $ampm;
  	$hr = 0 if $hr == 12 && $ampm eq 'AM';
  	$hr += 12 if $ampm eq 'PM' && $hr != 12;
      }
  
      return($yr, $mon, $day, $hr, $min, $sec, $tz)
  	if wantarray;
  
      if (defined $tz) {
  	$tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
      }
      else {
  	$tz = "";
      }
      return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
  		   $yr, $mon, $day, $hr, $min, $sec, $tz);
  }
  
  
  sub time2iso (;$)
  {
      my $time = shift;
      $time = time unless defined $time;
      my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
      sprintf("%04d-%02d-%02d %02d:%02d:%02d",
  	    $year+1900, $mon+1, $mday, $hour, $min, $sec);
  }
  
  
  sub time2isoz (;$)
  {
      my $time = shift;
      $time = time unless defined $time;
      my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time);
      sprintf("%04d-%02d-%02d %02d:%02d:%02dZ",
              $year+1900, $mon+1, $mday, $hour, $min, $sec);
  }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  HTTP::Date - date conversion routines
  
  =head1 SYNOPSIS
  
   use HTTP::Date;
  
   $string = time2str($time);    # Format as GMT ASCII time
   $time = str2time($string);    # convert ASCII date to machine time
  
  =head1 DESCRIPTION
  
  This module provides functions that deal the date formats used by the
  HTTP protocol (and then some more).  Only the first two functions,
  time2str() and str2time(), are exported by default.
  
  =over 4
  
  =item time2str( [$time] )
  
  The time2str() function converts a machine time (seconds since epoch)
  to a string.  If the function is called without an argument or with an
  undefined argument, it will use the current time.
  
  The string returned is in the format preferred for the HTTP protocol.
  This is a fixed length subset of the format defined by RFC 1123,
  represented in Universal Time (GMT).  An example of a time stamp
  in this format is:
  
     Sun, 06 Nov 1994 08:49:37 GMT
  
  =item str2time( $str [, $zone] )
  
  The str2time() function converts a string to machine time.  It returns
  C<undef> if the format of $str is unrecognized, otherwise whatever the
  C<Time::Local> functions can make out of the parsed time.  Dates
  before the system's epoch may not work on all operating systems.  The
  time formats recognized are the same as for parse_date().
  
  The function also takes an optional second argument that specifies the
  default time zone to use when converting the date.  This parameter is
  ignored if the zone is found in the date string itself.  If this
  parameter is missing, and the date string format does not contain any
  zone specification, then the local time zone is assumed.
  
  If the zone is not "C<GMT>" or numerical (like "C<-0800>" or
  "C<+0100>"), then the C<Time::Zone> module must be installed in order
  to get the date recognized.
  
  =item parse_date( $str )
  
  This function will try to parse a date string, and then return it as a
  list of numerical values followed by a (possible undefined) time zone
  specifier; ($year, $month, $day, $hour, $min, $sec, $tz).  The $year
  will be the full 4-digit year, and $month numbers start with 1 (for January).
  
  In scalar context the numbers are interpolated in a string of the
  "YYYY-MM-DD hh:mm:ss TZ"-format and returned.
  
  If the date is unrecognized, then the empty list is returned (C<undef> in
  scalar context).
  
  The function is able to parse the following formats:
  
   "Wed, 09 Feb 1994 22:23:32 GMT"       -- HTTP format
   "Thu Feb  3 17:03:55 GMT 1994"        -- ctime(3) format
   "Thu Feb  3 00:00:00 1994",           -- ANSI C asctime() format
   "Tuesday, 08-Feb-94 14:15:29 GMT"     -- old rfc850 HTTP format
   "Tuesday, 08-Feb-1994 14:15:29 GMT"   -- broken rfc850 HTTP format
  
   "03/Feb/1994:17:03:55 -0700"   -- common logfile format
   "09 Feb 1994 22:23:32 GMT"     -- HTTP format (no weekday)
   "08-Feb-94 14:15:29 GMT"       -- rfc850 format (no weekday)
   "08-Feb-1994 14:15:29 GMT"     -- broken rfc850 format (no weekday)
  
   "1994-02-03 14:15:29 -0100"    -- ISO 8601 format
   "1994-02-03 14:15:29"          -- zone is optional
   "1994-02-03"                   -- only date
   "1994-02-03T14:15:29"          -- Use T as separator
   "19940203T141529Z"             -- ISO 8601 compact format
   "19940203"                     -- only date
  
   "08-Feb-94"         -- old rfc850 HTTP format    (no weekday, no time)
   "08-Feb-1994"       -- broken rfc850 HTTP format (no weekday, no time)
   "09 Feb 1994"       -- proposed new HTTP format  (no weekday, no time)
   "03/Feb/1994"       -- common logfile format     (no time, no offset)
  
   "Feb  3  1994"      -- Unix 'ls -l' format
   "Feb  3 17:03"      -- Unix 'ls -l' format
  
   "11-15-96  03:52PM" -- Windows 'dir' format
  
  The parser ignores leading and trailing whitespace.  It also allow the
  seconds to be missing and the month to be numerical in most formats.
  
  If the year is missing, then we assume that the date is the first
  matching date I<before> current month.  If the year is given with only
  2 digits, then parse_date() will select the century that makes the
  year closest to the current date.
  
  =item time2iso( [$time] )
  
  Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
  string representing time in the local time zone.
  
  =item time2isoz( [$time] )
  
  Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
  string representing Universal Time.
  
  
  =back
  
  =head1 SEE ALSO
  
  L<perlfunc/time>, L<Time::Zone>
  
  =head1 COPYRIGHT
  
  Copyright 1995-1999, Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
HTTP_DATE

$fatpacked{"HTTP/Headers.pm"} = <<'HTTP_HEADERS';
  package HTTP::Headers;
  
  use strict;
  use Carp ();
  
  use vars qw($VERSION $TRANSLATE_UNDERSCORE);
  $VERSION = "6.05";
  
  # The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
  # as a replacement for '-' in header field names.
  $TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
  
  # "Good Practice" order of HTTP message headers:
  #    - General-Headers
  #    - Request-Headers
  #    - Response-Headers
  #    - Entity-Headers
  
  my @general_headers = qw(
      Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
      Via Warning
  );
  
  my @request_headers = qw(
      Accept Accept-Charset Accept-Encoding Accept-Language
      Authorization Expect From Host
      If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
      Max-Forwards Proxy-Authorization Range Referer TE User-Agent
  );
  
  my @response_headers = qw(
      Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
      Vary WWW-Authenticate
  );
  
  my @entity_headers = qw(
      Allow Content-Encoding Content-Language Content-Length Content-Location
      Content-MD5 Content-Range Content-Type Expires Last-Modified
  );
  
  my %entity_header = map { lc($_) => 1 } @entity_headers;
  
  my @header_order = (
      @general_headers,
      @request_headers,
      @response_headers,
      @entity_headers,
  );
  
  # Make alternative representations of @header_order.  This is used
  # for sorting and case matching.
  my %header_order;
  my %standard_case;
  
  {
      my $i = 0;
      for (@header_order) {
  	my $lc = lc $_;
  	$header_order{$lc} = ++$i;
  	$standard_case{$lc} = $_;
      }
  }
  
  
  
  sub new
  {
      my($class) = shift;
      my $self = bless {}, $class;
      $self->header(@_) if @_; # set up initial headers
      $self;
  }
  
  
  sub header
  {
      my $self = shift;
      Carp::croak('Usage: $h->header($field, ...)') unless @_;
      my(@old);
      my %seen;
      while (@_) {
  	my $field = shift;
          my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
  	@old = $self->_header($field, shift, $op);
      }
      return @old if wantarray;
      return $old[0] if @old <= 1;
      join(", ", @old);
  }
  
  sub clear
  {
      my $self = shift;
      %$self = ();
  }
  
  
  sub push_header
  {
      my $self = shift;
      return $self->_header(@_, 'PUSH_H') if @_ == 2;
      while (@_) {
  	$self->_header(splice(@_, 0, 2), 'PUSH_H');
      }
  }
  
  
  sub init_header
  {
      Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
      shift->_header(@_, 'INIT');
  }
  
  
  sub remove_header
  {
      my($self, @fields) = @_;
      my $field;
      my @values;
      foreach $field (@fields) {
  	$field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
  	my $v = delete $self->{lc $field};
  	push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
      }
      return @values;
  }
  
  sub remove_content_headers
  {
      my $self = shift;
      unless (defined(wantarray)) {
  	# fast branch that does not create return object
  	delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
  	return;
      }
  
      my $c = ref($self)->new;
      for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
  	$c->{$f} = delete $self->{$f};
      }
      if (exists $self->{'::std_case'}) {
  	$c->{'::std_case'} = $self->{'::std_case'};
      }
      $c;
  }
  
  
  sub _header
  {
      my($self, $field, $val, $op) = @_;
  
      Carp::croak("Illegal field name '$field'")
          if rindex($field, ':') > 1 || !length($field);
  
      unless ($field =~ /^:/) {
  	$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
  	my $old = $field;
  	$field = lc $field;
  	unless($standard_case{$field} || $self->{'::std_case'}{$field}) {
  	    # generate a %std_case entry for this field
  	    $old =~ s/\b(\w)/\u$1/g;
  	    $self->{'::std_case'}{$field} = $old;
  	}
      }
  
      $op ||= defined($val) ? 'SET' : 'GET';
      if ($op eq 'PUSH_H') {
  	# Like PUSH but where we don't care about the return value
  	if (exists $self->{$field}) {
  	    my $h = $self->{$field};
  	    if (ref($h) eq 'ARRAY') {
  		push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
  	    }
  	    else {
  		$self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
  	    }
  	    return;
  	}
  	$self->{$field} = $val;
  	return;
      }
  
      my $h = $self->{$field};
      my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
  
      unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
  	if (defined($val)) {
  	    my @new = ($op eq 'PUSH') ? @old : ();
  	    if (ref($val) ne 'ARRAY') {
  		push(@new, $val);
  	    }
  	    else {
  		push(@new, @$val);
  	    }
  	    $self->{$field} = @new > 1 ? \@new : $new[0];
  	}
  	elsif ($op ne 'PUSH') {
  	    delete $self->{$field};
  	}
      }
      @old;
  }
  
  
  sub _sorted_field_names
  {
      my $self = shift;
      return [ sort {
          ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
           $a cmp $b
      } grep !/^::/, keys %$self ];
  }
  
  
  sub header_field_names {
      my $self = shift;
      return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names },
  	if wantarray;
      return grep !/^::/, keys %$self;
  }
  
  
  sub scan
  {
      my($self, $sub) = @_;
      my $key;
      for $key (@{ $self->_sorted_field_names }) {
  	my $vals = $self->{$key};
  	if (ref($vals) eq 'ARRAY') {
  	    my $val;
  	    for $val (@$vals) {
  		$sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val);
  	    }
  	}
  	else {
  	    $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals);
  	}
      }
  }
  
  
  sub as_string
  {
      my($self, $endl) = @_;
      $endl = "\n" unless defined $endl;
  
      my @result = ();
      for my $key (@{ $self->_sorted_field_names }) {
  	next if index($key, '_') == 0;
  	my $vals = $self->{$key};
  	if ( ref($vals) eq 'ARRAY' ) {
  	    for my $val (@$vals) {
  		my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
  		$field =~ s/^://;
  		if ( index($val, "\n") >= 0 ) {
  		    $val = _process_newline($val, $endl);
  		}
  		push @result, $field . ': ' . $val;
  	    }
  	}
  	else {
  	    my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
  	    $field =~ s/^://;
  	    if ( index($vals, "\n") >= 0 ) {
  		$vals = _process_newline($vals, $endl);
  	    }
  	    push @result, $field . ': ' . $vals;
  	}
      }
  
      join($endl, @result, '');
  }
  
  sub _process_newline {
      local $_ = shift;
      my $endl = shift;
      # must handle header values with embedded newlines with care
      s/\s+$//;        # trailing newlines and space must go
      s/\n(\x0d?\n)+/\n/g;     # no empty lines
      s/\n([^\040\t])/\n $1/g; # initial space for continuation
      s/\n/$endl/g;    # substitute with requested line ending
      $_;
  }
  
  
  
  if (eval { require Storable; 1 }) {
      *clone = \&Storable::dclone;
  } else {
      *clone = sub {
  	my $self = shift;
  	my $clone = HTTP::Headers->new;
  	$self->scan(sub { $clone->push_header(@_);} );
  	$clone;
      };
  }
  
  
  sub _date_header
  {
      require HTTP::Date;
      my($self, $header, $time) = @_;
      my($old) = $self->_header($header);
      if (defined $time) {
  	$self->_header($header, HTTP::Date::time2str($time));
      }
      $old =~ s/;.*// if defined($old);
      HTTP::Date::str2time($old);
  }
  
  
  sub date                { shift->_date_header('Date',                @_); }
  sub expires             { shift->_date_header('Expires',             @_); }
  sub if_modified_since   { shift->_date_header('If-Modified-Since',   @_); }
  sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
  sub last_modified       { shift->_date_header('Last-Modified',       @_); }
  
  # This is used as a private LWP extension.  The Client-Date header is
  # added as a timestamp to a response when it has been received.
  sub client_date         { shift->_date_header('Client-Date',         @_); }
  
  # The retry_after field is dual format (can also be a expressed as
  # number of seconds from now), so we don't provide an easy way to
  # access it until we have know how both these interfaces can be
  # addressed.  One possibility is to return a negative value for
  # relative seconds and a positive value for epoch based time values.
  #sub retry_after       { shift->_date_header('Retry-After',       @_); }
  
  sub content_type      {
      my $self = shift;
      my $ct = $self->{'content-type'};
      $self->{'content-type'} = shift if @_;
      $ct = $ct->[0] if ref($ct) eq 'ARRAY';
      return '' unless defined($ct) && length($ct);
      my @ct = split(/;\s*/, $ct, 2);
      for ($ct[0]) {
  	s/\s+//g;
  	$_ = lc($_);
      }
      wantarray ? @ct : $ct[0];
  }
  
  sub content_type_charset {
      my $self = shift;
      require HTTP::Headers::Util;
      my $h = $self->{'content-type'};
      $h = $h->[0] if ref($h);
      $h = "" unless defined $h;
      my @v = HTTP::Headers::Util::split_header_words($h);
      if (@v) {
  	my($ct, undef, %ct_param) = @{$v[0]};
  	my $charset = $ct_param{charset};
  	if ($ct) {
  	    $ct = lc($ct);
  	    $ct =~ s/\s+//;
  	}
  	if ($charset) {
  	    $charset = uc($charset);
  	    $charset =~ s/^\s+//;  $charset =~ s/\s+\z//;
  	    undef($charset) if $charset eq "";
  	}
  	return $ct, $charset if wantarray;
  	return $charset;
      }
      return undef, undef if wantarray;
      return undef;
  }
  
  sub content_is_text {
      my $self = shift;
      return $self->content_type =~ m,^text/,;
  }
  
  sub content_is_html {
      my $self = shift;
      return $self->content_type eq 'text/html' || $self->content_is_xhtml;
  }
  
  sub content_is_xhtml {
      my $ct = shift->content_type;
      return $ct eq "application/xhtml+xml" ||
             $ct eq "application/vnd.wap.xhtml+xml";
  }
  
  sub content_is_xml {
      my $ct = shift->content_type;
      return 1 if $ct eq "text/xml";
      return 1 if $ct eq "application/xml";
      return 1 if $ct =~ /\+xml$/;
      return 0;
  }
  
  sub referer           {
      my $self = shift;
      if (@_ && $_[0] =~ /#/) {
  	# Strip fragment per RFC 2616, section 14.36.
  	my $uri = shift;
  	if (ref($uri)) {
  	    $uri = $uri->clone;
  	    $uri->fragment(undef);
  	}
  	else {
  	    $uri =~ s/\#.*//;
  	}
  	unshift @_, $uri;
      }
      ($self->_header('Referer', @_))[0];
  }
  *referrer = \&referer;  # on tchrist's request
  
  sub title             { (shift->_header('Title',            @_))[0] }
  sub content_encoding  { (shift->_header('Content-Encoding', @_))[0] }
  sub content_language  { (shift->_header('Content-Language', @_))[0] }
  sub content_length    { (shift->_header('Content-Length',   @_))[0] }
  
  sub user_agent        { (shift->_header('User-Agent',       @_))[0] }
  sub server            { (shift->_header('Server',           @_))[0] }
  
  sub from              { (shift->_header('From',             @_))[0] }
  sub warning           { (shift->_header('Warning',          @_))[0] }
  
  sub www_authenticate  { (shift->_header('WWW-Authenticate', @_))[0] }
  sub authorization     { (shift->_header('Authorization',    @_))[0] }
  
  sub proxy_authenticate  { (shift->_header('Proxy-Authenticate',  @_))[0] }
  sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
  
  sub authorization_basic       { shift->_basic_auth("Authorization",       @_) }
  sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
  
  sub _basic_auth {
      require MIME::Base64;
      my($self, $h, $user, $passwd) = @_;
      my($old) = $self->_header($h);
      if (defined $user) {
  	Carp::croak("Basic authorization user name can't contain ':'")
  	  if $user =~ /:/;
  	$passwd = '' unless defined $passwd;
  	$self->_header($h => 'Basic ' .
                               MIME::Base64::encode("$user:$passwd", ''));
      }
      if (defined $old && $old =~ s/^\s*Basic\s+//) {
  	my $val = MIME::Base64::decode($old);
  	return $val unless wantarray;
  	return split(/:/, $val, 2);
      }
      return;
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Headers - Class encapsulating HTTP Message headers
  
  =head1 SYNOPSIS
  
   require HTTP::Headers;
   $h = HTTP::Headers->new;
  
   $h->header('Content-Type' => 'text/plain');  # set
   $ct = $h->header('Content-Type');            # get
   $h->remove_header('Content-Type');           # delete
  
  =head1 DESCRIPTION
  
  The C<HTTP::Headers> class encapsulates HTTP-style message headers.
  The headers consist of attribute-value pairs also called fields, which
  may be repeated, and which are printed in a particular order.  The
  field names are cases insensitive.
  
  Instances of this class are usually created as member variables of the
  C<HTTP::Request> and C<HTTP::Response> classes, internal to the
  library.
  
  The following methods are available:
  
  =over 4
  
  =item $h = HTTP::Headers->new
  
  Constructs a new C<HTTP::Headers> object.  You might pass some initial
  attribute-value pairs as parameters to the constructor.  I<E.g.>:
  
   $h = HTTP::Headers->new(
         Date         => 'Thu, 03 Feb 1994 00:00:00 GMT',
         Content_Type => 'text/html; version=3.2',
         Content_Base => 'http://www.perl.org/');
  
  The constructor arguments are passed to the C<header> method which is
  described below.
  
  =item $h->clone
  
  Returns a copy of this C<HTTP::Headers> object.
  
  =item $h->header( $field )
  
  =item $h->header( $field => $value )
  
  =item $h->header( $f1 => $v1, $f2 => $v2, ... )
  
  Get or set the value of one or more header fields.  The header field
  name ($field) is not case sensitive.  To make the life easier for perl
  users who wants to avoid quoting before the => operator, you can use
  '_' as a replacement for '-' in header names.
  
  The header() method accepts multiple ($field => $value) pairs, which
  means that you can update several fields with a single invocation.
  
  The $value argument may be a plain string or a reference to an array
  of strings for a multi-valued field. If the $value is provided as
  C<undef> then the field is removed.  If the $value is not given, then
  that header field will remain unchanged.
  
  The old value (or values) of the last of the header fields is returned.
  If no such field exists C<undef> will be returned.
  
  A multi-valued field will be returned as separate values in list
  context and will be concatenated with ", " as separator in scalar
  context.  The HTTP spec (RFC 2616) promise that joining multiple
  values in this way will not change the semantic of a header field, but
  in practice there are cases like old-style Netscape cookies (see
  L<HTTP::Cookies>) where "," is used as part of the syntax of a single
  field value.
  
  Examples:
  
   $header->header(MIME_Version => '1.0',
  		 User_Agent   => 'My-Web-Client/0.01');
   $header->header(Accept => "text/html, text/plain, image/*");
   $header->header(Accept => [qw(text/html text/plain image/*)]);
   @accepts = $header->header('Accept');  # get multiple values
   $accepts = $header->header('Accept');  # get values as a single string
  
  =item $h->push_header( $field => $value )
  
  =item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
  
  Add a new field value for the specified header field.  Previous values
  for the same field are retained.
  
  As for the header() method, the field name ($field) is not case
  sensitive and '_' can be used as a replacement for '-'.
  
  The $value argument may be a scalar or a reference to a list of
  scalars.
  
   $header->push_header(Accept => 'image/jpeg');
   $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
  
  =item $h->init_header( $field => $value )
  
  Set the specified header to the given value, but only if no previous
  value for that field is set.
  
  The header field name ($field) is not case sensitive and '_'
  can be used as a replacement for '-'.
  
  The $value argument may be a scalar or a reference to a list of
  scalars.
  
  =item $h->remove_header( $field, ... )
  
  This function removes the header fields with the specified names.
  
  The header field names ($field) are not case sensitive and '_'
  can be used as a replacement for '-'.
  
  The return value is the values of the fields removed.  In scalar
  context the number of fields removed is returned.
  
  Note that if you pass in multiple field names then it is generally not
  possible to tell which of the returned values belonged to which field.
  
  =item $h->remove_content_headers
  
  This will remove all the header fields used to describe the content of
  a message.  All header field names prefixed with C<Content-> fall
  into this category, as well as C<Allow>, C<Expires> and
  C<Last-Modified>.  RFC 2616 denotes these fields as I<Entity Header
  Fields>.
  
  The return value is a new C<HTTP::Headers> object that contains the
  removed headers only.
  
  =item $h->clear
  
  This will remove all header fields.
  
  =item $h->header_field_names
  
  Returns the list of distinct names for the fields present in the
  header.  The field names have case as suggested by HTTP spec, and the
  names are returned in the recommended "Good Practice" order.
  
  In scalar context return the number of distinct field names.
  
  =item $h->scan( \&process_header_field )
  
  Apply a subroutine to each header field in turn.  The callback routine
  is called with two parameters; the name of the field and a single
  value (a string).  If a header field is multi-valued, then the
  routine is called once for each value.  The field name passed to the
  callback routine has case as suggested by HTTP spec, and the headers
  will be visited in the recommended "Good Practice" order.
  
  Any return values of the callback routine are ignored.  The loop can
  be broken by raising an exception (C<die>), but the caller of scan()
  would have to trap the exception itself.
  
  =item $h->as_string
  
  =item $h->as_string( $eol )
  
  Return the header fields as a formatted MIME header.  Since it
  internally uses the C<scan> method to build the string, the result
  will use case as suggested by HTTP spec, and it will follow
  recommended "Good Practice" of ordering the header fields.  Long header
  values are not folded.
  
  The optional $eol parameter specifies the line ending sequence to
  use.  The default is "\n".  Embedded "\n" characters in header field
  values will be substituted with this line ending sequence.
  
  =back
  
  =head1 CONVENIENCE METHODS
  
  The most frequently used headers can also be accessed through the
  following convenience methods.  Most of these methods can both be used to read
  and to set the value of a header.  The header value is set if you pass
  an argument to the method.  The old header value is always returned.
  If the given header did not exist then C<undef> is returned.
  
  Methods that deal with dates/times always convert their value to system
  time (seconds since Jan 1, 1970) and they also expect this kind of
  value when the header value is set.
  
  =over 4
  
  =item $h->date
  
  This header represents the date and time at which the message was
  originated. I<E.g.>:
  
    $h->date(time);  # set current date
  
  =item $h->expires
  
  This header gives the date and time after which the entity should be
  considered stale.
  
  =item $h->if_modified_since
  
  =item $h->if_unmodified_since
  
  These header fields are used to make a request conditional.  If the requested
  resource has (or has not) been modified since the time specified in this field,
  then the server will return a C<304 Not Modified> response instead of
  the document itself.
  
  =item $h->last_modified
  
  This header indicates the date and time at which the resource was last
  modified. I<E.g.>:
  
    # check if document is more than 1 hour old
    if (my $last_mod = $h->last_modified) {
        if ($last_mod < time - 60*60) {
  	  ...
        }
    }
  
  =item $h->content_type
  
  The Content-Type header field indicates the media type of the message
  content. I<E.g.>:
  
    $h->content_type('text/html');
  
  The value returned will be converted to lower case, and potential
  parameters will be chopped off and returned as a separate value if in
  an array context.  If there is no such header field, then the empty
  string is returned.  This makes it safe to do the following:
  
    if ($h->content_type eq 'text/html') {
       # we enter this place even if the real header value happens to
       # be 'TEXT/HTML; version=3.0'
       ...
    }
  
  =item $h->content_type_charset
  
  Returns the upper-cased charset specified in the Content-Type header.  In list
  context return the lower-cased bare content type followed by the upper-cased
  charset.  Both values will be C<undef> if not specified in the header.
  
  =item $h->content_is_text
  
  Returns TRUE if the Content-Type header field indicate that the
  content is textual.
  
  =item $h->content_is_html
  
  Returns TRUE if the Content-Type header field indicate that the
  content is some kind of HTML (including XHTML).  This method can't be
  used to set Content-Type.
  
  =item $h->content_is_xhtml
  
  Returns TRUE if the Content-Type header field indicate that the
  content is XHTML.  This method can't be used to set Content-Type.
  
  =item $h->content_is_xml
  
  Returns TRUE if the Content-Type header field indicate that the
  content is XML.  This method can't be used to set Content-Type.
  
  =item $h->content_encoding
  
  The Content-Encoding header field is used as a modifier to the
  media type.  When present, its value indicates what additional
  encoding mechanism has been applied to the resource.
  
  =item $h->content_length
  
  A decimal number indicating the size in bytes of the message content.
  
  =item $h->content_language
  
  The natural language(s) of the intended audience for the message
  content.  The value is one or more language tags as defined by RFC
  1766.  Eg. "no" for some kind of Norwegian and "en-US" for English the
  way it is written in the US.
  
  =item $h->title
  
  The title of the document.  In libwww-perl this header will be
  initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
  of HTML documents.  I<This header is no longer part of the HTTP
  standard.>
  
  =item $h->user_agent
  
  This header field is used in request messages and contains information
  about the user agent originating the request.  I<E.g.>:
  
    $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
  
  =item $h->server
  
  The server header field contains information about the software being
  used by the originating server program handling the request.
  
  =item $h->from
  
  This header should contain an Internet e-mail address for the human
  user who controls the requesting user agent.  The address should be
  machine-usable, as defined by RFC822.  E.g.:
  
    $h->from('King Kong <king@kong.com>');
  
  I<This header is no longer part of the HTTP standard.>
  
  =item $h->referer
  
  Used to specify the address (URI) of the document from which the
  requested resource address was obtained.
  
  The "Free On-line Dictionary of Computing" as this to say about the
  word I<referer>:
  
       <World-Wide Web> A misspelling of "referrer" which
       somehow made it into the {HTTP} standard.  A given {web
       page}'s referer (sic) is the {URL} of whatever web page
       contains the link that the user followed to the current
       page.  Most browsers pass this information as part of a
       request.
  
       (1998-10-19)
  
  By popular demand C<referrer> exists as an alias for this method so you
  can avoid this misspelling in your programs and still send the right
  thing on the wire.
  
  When setting the referrer, this method removes the fragment from the
  given URI if it is present, as mandated by RFC2616.  Note that
  the removal does I<not> happen automatically if using the header(),
  push_header() or init_header() methods to set the referrer.
  
  =item $h->www_authenticate
  
  This header must be included as part of a C<401 Unauthorized> response.
  The field value consist of a challenge that indicates the
  authentication scheme and parameters applicable to the requested URI.
  
  =item $h->proxy_authenticate
  
  This header must be included in a C<407 Proxy Authentication Required>
  response.
  
  =item $h->authorization
  
  =item $h->proxy_authorization
  
  A user agent that wishes to authenticate itself with a server or a
  proxy, may do so by including these headers.
  
  =item $h->authorization_basic
  
  This method is used to get or set an authorization header that use the
  "Basic Authentication Scheme".  In array context it will return two
  values; the user name and the password.  In scalar context it will
  return I<"uname:password"> as a single string value.
  
  When used to set the header value, it expects two arguments.  I<E.g.>:
  
    $h->authorization_basic($uname, $password);
  
  The method will croak if the $uname contains a colon ':'.
  
  =item $h->proxy_authorization_basic
  
  Same as authorization_basic() but will set the "Proxy-Authorization"
  header instead.
  
  =back
  
  =head1 NON-CANONICALIZED FIELD NAMES
  
  The header field name spelling is normally canonicalized including the
  '_' to '-' translation.  There are some application where this is not
  appropriate.  Prefixing field names with ':' allow you to force a
  specific spelling.  For example if you really want a header field name
  to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
  this:
  
    $h->header(":foo_bar" => 1);
  
  These field names are returned with the ':' intact for
  $h->header_field_names and the $h->scan callback, but the colons do
  not show in $h->as_string.
  
  =head1 COPYRIGHT
  
  Copyright 1995-2005 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
HTTP_HEADERS

$fatpacked{"HTTP/Headers/Auth.pm"} = <<'HTTP_HEADERS_AUTH';
  package HTTP::Headers::Auth;
  
  use strict;
  use vars qw($VERSION);
  $VERSION = "6.00";
  
  use HTTP::Headers;
  
  package HTTP::Headers;
  
  BEGIN {
      # we provide a new (and better) implementations below
      undef(&www_authenticate);
      undef(&proxy_authenticate);
  }
  
  require HTTP::Headers::Util;
  
  sub _parse_authenticate
  {
      my @ret;
      for (HTTP::Headers::Util::split_header_words(@_)) {
  	if (!defined($_->[1])) {
  	    # this is a new auth scheme
  	    push(@ret, shift(@$_) => {});
  	    shift @$_;
  	}
  	if (@ret) {
  	    # this a new parameter pair for the last auth scheme
  	    while (@$_) {
  		my $k = shift @$_;
  		my $v = shift @$_;
  	        $ret[-1]{$k} = $v;
  	    }
  	}
  	else {
  	    # something wrong, parameter pair without any scheme seen
  	    # IGNORE
  	}
      }
      @ret;
  }
  
  sub _authenticate
  {
      my $self = shift;
      my $header = shift;
      my @old = $self->_header($header);
      if (@_) {
  	$self->remove_header($header);
  	my @new = @_;
  	while (@new) {
  	    my $a_scheme = shift(@new);
  	    if ($a_scheme =~ /\s/) {
  		# assume complete valid value, pass it through
  		$self->push_header($header, $a_scheme);
  	    }
  	    else {
  		my @param;
  		if (@new) {
  		    my $p = $new[0];
  		    if (ref($p) eq "ARRAY") {
  			@param = @$p;
  			shift(@new);
  		    }
  		    elsif (ref($p) eq "HASH") {
  			@param = %$p;
  			shift(@new);
  		    }
  		}
  		my $val = ucfirst(lc($a_scheme));
  		if (@param) {
  		    my $sep = " ";
  		    while (@param) {
  			my $k = shift @param;
  			my $v = shift @param;
  			if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
  			    # must quote the value
  			    $v =~ s,([\\\"]),\\$1,g;
  			    $v = qq("$v");
  			}
  			$val .= "$sep$k=$v";
  			$sep = ", ";
  		    }
  		}
  		$self->push_header($header, $val);
  	    }
  	}
      }
      return unless defined wantarray;
      wantarray ? _parse_authenticate(@old) : join(", ", @old);
  }
  
  
  sub www_authenticate    { shift->_authenticate("WWW-Authenticate", @_)   }
  sub proxy_authenticate  { shift->_authenticate("Proxy-Authenticate", @_) }
  
  1;
HTTP_HEADERS_AUTH

$fatpacked{"HTTP/Headers/ETag.pm"} = <<'HTTP_HEADERS_ETAG';
  package HTTP::Headers::ETag;
  
  use strict;
  use vars qw($VERSION);
  $VERSION = "6.00";
  
  require HTTP::Date;
  
  require HTTP::Headers;
  package HTTP::Headers;
  
  sub _etags
  {
      my $self = shift;
      my $header = shift;
      my @old = _split_etag_list($self->_header($header));
      if (@_) {
  	$self->_header($header => join(", ", _split_etag_list(@_)));
      }
      wantarray ? @old : join(", ", @old);
  }
  
  sub etag          { shift->_etags("ETag", @_); }
  sub if_match      { shift->_etags("If-Match", @_); }
  sub if_none_match { shift->_etags("If-None-Match", @_); }
  
  sub if_range {
      # Either a date or an entity-tag
      my $self = shift;
      my @old = $self->_header("If-Range");
      if (@_) {
  	my $new = shift;
  	if (!defined $new) {
  	    $self->remove_header("If-Range");
  	}
  	elsif ($new =~ /^\d+$/) {
  	    $self->_date_header("If-Range", $new);
  	}
  	else {
  	    $self->_etags("If-Range", $new);
  	}
      }
      return unless defined(wantarray);
      for (@old) {
  	my $t = HTTP::Date::str2time($_);
  	$_ = $t if $t;
      }
      wantarray ? @old : join(", ", @old);
  }
  
  
  # Split a list of entity tag values.  The return value is a list
  # consisting of one element per entity tag.  Suitable for parsing
  # headers like C<If-Match>, C<If-None-Match>.  You might even want to
  # use it on C<ETag> and C<If-Range> entity tag values, because it will
  # normalize them to the common form.
  #
  #  entity-tag	  = [ weak ] opaque-tag
  #  weak		  = "W/"
  #  opaque-tag	  = quoted-string
  
  
  sub _split_etag_list
  {
      my(@val) = @_;
      my @res;
      for (@val) {
          while (length) {
              my $weak = "";
  	    $weak = "W/" if s,^\s*[wW]/,,;
              my $etag = "";
  	    if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
  		push(@res, "$weak$1");
              }
              elsif (s/^\s*,//) {
                  push(@res, qq(W/"")) if $weak;
              }
              elsif (s/^\s*([^,\s]+)//) {
                  $etag = $1;
  		$etag =~ s/([\"\\])/\\$1/g;
  	        push(@res, qq($weak"$etag"));
              }
              elsif (s/^\s+// || !length) {
                  push(@res, qq(W/"")) if $weak;
              }
              else {
  	 	die "This should not happen: '$_'";
              }
          }
     }
     @res;
  }
  
  1;
HTTP_HEADERS_ETAG

$fatpacked{"HTTP/Headers/Util.pm"} = <<'HTTP_HEADERS_UTIL';
  package HTTP::Headers::Util;
  
  use strict;
  use vars qw($VERSION @ISA @EXPORT_OK);
  
  $VERSION = "6.03";
  
  require Exporter;
  @ISA=qw(Exporter);
  
  @EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
  
  
  
  sub split_header_words {
      my @res = &_split_header_words;
      for my $arr (@res) {
  	for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
  	    $arr->[$i] = lc($arr->[$i]);
  	}
      }
      return @res;
  }
  
  sub _split_header_words
  {
      my(@val) = @_;
      my @res;
      for (@val) {
  	my @cur;
  	while (length) {
  	    if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
  		push(@cur, $1);
  		# a quoted value
  		if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
  		    my $val = $1;
  		    $val =~ s/\\(.)/$1/g;
  		    push(@cur, $val);
  		# some unquoted value
  		}
  		elsif (s/^\s*=\s*([^;,\s]*)//) {
  		    my $val = $1;
  		    $val =~ s/\s+$//;
  		    push(@cur, $val);
  		# no value, a lone token
  		}
  		else {
  		    push(@cur, undef);
  		}
  	    }
  	    elsif (s/^\s*,//) {
  		push(@res, [@cur]) if @cur;
  		@cur = ();
  	    }
  	    elsif (s/^\s*;// || s/^\s+//) {
  		# continue
  	    }
  	    else {
  		die "This should not happen: '$_'";
  	    }
  	}
  	push(@res, \@cur) if @cur;
      }
      @res;
  }
  
  
  sub join_header_words
  {
      @_ = ([@_]) if @_ && !ref($_[0]);
      my @res;
      for (@_) {
  	my @cur = @$_;
  	my @attr;
  	while (@cur) {
  	    my $k = shift @cur;
  	    my $v = shift @cur;
  	    if (defined $v) {
  		if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
  		    $v =~ s/([\"\\])/\\$1/g;  # escape " and \
  		    $k .= qq(="$v");
  		}
  		else {
  		    # token
  		    $k .= "=$v";
  		}
  	    }
  	    push(@attr, $k);
  	}
  	push(@res, join("; ", @attr)) if @attr;
      }
      join(", ", @res);
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Headers::Util - Header value parsing utility functions
  
  =head1 SYNOPSIS
  
    use HTTP::Headers::Util qw(split_header_words);
    @values = split_header_words($h->header("Content-Type"));
  
  =head1 DESCRIPTION
  
  This module provides a few functions that helps parsing and
  construction of valid HTTP header values.  None of the functions are
  exported by default.
  
  The following functions are available:
  
  =over 4
  
  
  =item split_header_words( @header_values )
  
  This function will parse the header values given as argument into a
  list of anonymous arrays containing key/value pairs.  The function
  knows how to deal with ",", ";" and "=" as well as quoted values after
  "=".  A list of space separated tokens are parsed as if they were
  separated by ";".
  
  If the @header_values passed as argument contains multiple values,
  then they are treated as if they were a single value separated by
  comma ",".
  
  This means that this function is useful for parsing header fields that
  follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
  the requirement for tokens).
  
    headers           = #header
    header            = (token | parameter) *( [";"] (token | parameter))
  
    token             = 1*<any CHAR except CTLs or separators>
    separators        = "(" | ")" | "<" | ">" | "@"
                      | "," | ";" | ":" | "\" | <">
                      | "/" | "[" | "]" | "?" | "="
                      | "{" | "}" | SP | HT
  
    quoted-string     = ( <"> *(qdtext | quoted-pair ) <"> )
    qdtext            = <any TEXT except <">>
    quoted-pair       = "\" CHAR
  
    parameter         = attribute "=" value
    attribute         = token
    value             = token | quoted-string
  
  Each I<header> is represented by an anonymous array of key/value
  pairs.  The keys will be all be forced to lower case.
  The value for a simple token (not part of a parameter) is C<undef>.
  Syntactically incorrect headers will not necessarily be parsed as you
  would want.
  
  This is easier to describe with some examples:
  
     split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
     split_header_words('text/html; charset="iso-8859-1"');
     split_header_words('Basic realm="\\"foo\\\\bar\\""');
  
  will return
  
     [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
     ['text/html' => undef, charset => 'iso-8859-1']
     [basic => undef, realm => "\"foo\\bar\""]
  
  If you don't want the function to convert tokens and attribute keys to
  lower case you can call it as C<_split_header_words> instead (with a
  leading underscore).
  
  =item join_header_words( @arrays )
  
  This will do the opposite of the conversion done by split_header_words().
  It takes a list of anonymous arrays as arguments (or a list of
  key/value pairs) and produces a single header value.  Attribute values
  are quoted if needed.
  
  Example:
  
     join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
     join_header_words("text/plain" => undef, charset => "iso-8859/1");
  
  will both return the string:
  
     text/plain; charset="iso-8859/1"
  
  =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.
  
HTTP_HEADERS_UTIL

$fatpacked{"HTTP/Message.pm"} = <<'HTTP_MESSAGE';
  package HTTP::Message;
  
  use strict;
  use vars qw($VERSION $AUTOLOAD);
  $VERSION = "6.06";
  
  require HTTP::Headers;
  require Carp;
  
  my $CRLF = "\015\012";   # "\r\n" is not portable
  unless ($HTTP::URI_CLASS) {
      if ($ENV{PERL_HTTP_URI_CLASS}
      &&  $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) {
          $HTTP::URI_CLASS = $1;
      } else {
          $HTTP::URI_CLASS = "URI";
      }
  }
  eval "require $HTTP::URI_CLASS"; die $@ if $@;
  
  *_utf8_downgrade = defined(&utf8::downgrade) ?
      sub {
          utf8::downgrade($_[0], 1) or
              Carp::croak("HTTP::Message content must be bytes")
      }
      :
      sub {
      };
  
  sub new
  {
      my($class, $header, $content) = @_;
      if (defined $header) {
  	Carp::croak("Bad header argument") unless ref $header;
          if (ref($header) eq "ARRAY") {
  	    $header = HTTP::Headers->new(@$header);
  	}
  	else {
  	    $header = $header->clone;
  	}
      }
      else {
  	$header = HTTP::Headers->new;
      }
      if (defined $content) {
          _utf8_downgrade($content);
      }
      else {
          $content = '';
      }
  
      bless {
  	'_headers' => $header,
  	'_content' => $content,
      }, $class;
  }
  
  
  sub parse
  {
      my($class, $str) = @_;
  
      my @hdr;
      while (1) {
  	if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
  	    push(@hdr, $1, $2);
  	    $hdr[-1] =~ s/\r\z//;
  	}
  	elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
  	    $hdr[-1] .= "\n$1";
  	    $hdr[-1] =~ s/\r\z//;
  	}
  	else {
  	    $str =~ s/^\r?\n//;
  	    last;
  	}
      }
      local $HTTP::Headers::TRANSLATE_UNDERSCORE;
      new($class, \@hdr, $str);
  }
  
  
  sub clone
  {
      my $self  = shift;
      my $clone = HTTP::Message->new($self->headers,
  				   $self->content);
      $clone->protocol($self->protocol);
      $clone;
  }
  
  
  sub clear {
      my $self = shift;
      $self->{_headers}->clear;
      $self->content("");
      delete $self->{_parts};
      return;
  }
  
  
  sub protocol {
      shift->_elem('_protocol',  @_);
  }
  
  sub headers {
      my $self = shift;
  
      # recalculation of _content might change headers, so we
      # need to force it now
      $self->_content unless exists $self->{_content};
  
      $self->{_headers};
  }
  
  sub headers_as_string {
      shift->headers->as_string(@_);
  }
  
  
  sub content  {
  
      my $self = $_[0];
      if (defined(wantarray)) {
  	$self->_content unless exists $self->{_content};
  	my $old = $self->{_content};
  	$old = $$old if ref($old) eq "SCALAR";
  	&_set_content if @_ > 1;
  	return $old;
      }
  
      if (@_ > 1) {
  	&_set_content;
      }
      else {
  	Carp::carp("Useless content call in void context") if $^W;
      }
  }
  
  
  sub _set_content {
      my $self = $_[0];
      _utf8_downgrade($_[1]);
      if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
  	${$self->{_content}} = $_[1];
      }
      else {
  	die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
  	$self->{_content} = $_[1];
  	delete $self->{_content_ref};
      }
      delete $self->{_parts} unless $_[2];
  }
  
  
  sub add_content
  {
      my $self = shift;
      $self->_content unless exists $self->{_content};
      my $chunkref = \$_[0];
      $chunkref = $$chunkref if ref($$chunkref);  # legacy
  
      _utf8_downgrade($$chunkref);
  
      my $ref = ref($self->{_content});
      if (!$ref) {
  	$self->{_content} .= $$chunkref;
      }
      elsif ($ref eq "SCALAR") {
  	${$self->{_content}} .= $$chunkref;
      }
      else {
  	Carp::croak("Can't append to $ref content");
      }
      delete $self->{_parts};
  }
  
  sub add_content_utf8 {
      my($self, $buf)  = @_;
      utf8::upgrade($buf);
      utf8::encode($buf);
      $self->add_content($buf);
  }
  
  sub content_ref
  {
      my $self = shift;
      $self->_content unless exists $self->{_content};
      delete $self->{_parts};
      my $old = \$self->{_content};
      my $old_cref = $self->{_content_ref};
      if (@_) {
  	my $new = shift;
  	Carp::croak("Setting content_ref to a non-ref") unless ref($new);
  	delete $self->{_content};  # avoid modifying $$old
  	$self->{_content} = $new;
  	$self->{_content_ref}++;
      }
      $old = $$old if $old_cref;
      return $old;
  }
  
  
  sub content_charset
  {
      my $self = shift;
      if (my $charset = $self->content_type_charset) {
  	return $charset;
      }
  
      # time to start guessing
      my $cref = $self->decoded_content(ref => 1, charset => "none");
  
      # Unicode BOM
      for ($$cref) {
  	return "UTF-8"     if /^\xEF\xBB\xBF/;
  	return "UTF-32LE" if /^\xFF\xFE\x00\x00/;
  	return "UTF-32BE" if /^\x00\x00\xFE\xFF/;
  	return "UTF-16LE" if /^\xFF\xFE/;
  	return "UTF-16BE" if /^\xFE\xFF/;
      }
  
      if ($self->content_is_xml) {
  	# http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
  	# XML entity not accompanied by external encoding information and not
  	# in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
  	# in which the first characters must be '<?xml'
  	for ($$cref) {
  	    return "UTF-32BE" if /^\x00\x00\x00</;
  	    return "UTF-32LE" if /^<\x00\x00\x00/;
  	    return "UTF-16BE" if /^(?:\x00\s)*\x00</;
  	    return "UTF-16LE" if /^(?:\s\x00)*<\x00/;
  	    if (/^\s*(<\?xml[^\x00]*?\?>)/) {
  		if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
  		    my $enc = $2;
  		    $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
  		    return $enc if $enc;
  		}
  	    }
  	}
  	return "UTF-8";
      }
      elsif ($self->content_is_html) {
  	# look for <META charset="..."> or <META content="...">
  	# http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
  	require IO::HTML;
  	# Use relaxed search to match previous versions of HTTP::Message:
  	my $encoding = IO::HTML::find_charset_in($$cref, { encoding    => 1,
  	                                                   need_pragma => 0 });
  	return $encoding->mime_name if $encoding;
      }
      elsif ($self->content_type eq "application/json") {
  	for ($$cref) {
  	    # RFC 4627, ch 3
  	    return "UTF-32BE" if /^\x00\x00\x00./s;
  	    return "UTF-32LE" if /^.\x00\x00\x00/s;
  	    return "UTF-16BE" if /^\x00.\x00./s;
  	    return "UTF-16LE" if /^.\x00.\x00/s;
  	    return "UTF-8";
  	}
      }
      if ($self->content_type =~ /^text\//) {
  	for ($$cref) {
  	    if (length) {
  		return "US-ASCII" unless /[\x80-\xFF]/;
  		require Encode;
  		eval {
  		    Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
  		};
  		return "UTF-8" unless $@;
  		return "ISO-8859-1";
  	    }
  	}
      }
  
      return undef;
  }
  
  
  sub decoded_content
  {
      my($self, %opt) = @_;
      my $content_ref;
      my $content_ref_iscopy;
  
      eval {
  	$content_ref = $self->content_ref;
  	die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
  
  	if (my $h = $self->header("Content-Encoding")) {
  	    $h =~ s/^\s+//;
  	    $h =~ s/\s+$//;
  	    for my $ce (reverse split(/\s*,\s*/, lc($h))) {
  		next unless $ce;
  		next if $ce eq "identity";
  		if ($ce eq "gzip" || $ce eq "x-gzip") {
  		    require IO::Uncompress::Gunzip;
  		    my $output;
  		    IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
  			or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
  		    $content_ref = \$output;
  		    $content_ref_iscopy++;
  		}
  		elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
  		    require IO::Uncompress::Bunzip2;
  		    my $output;
  		    IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
  			or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
  		    $content_ref = \$output;
  		    $content_ref_iscopy++;
  		}
  		elsif ($ce eq "deflate") {
  		    require IO::Uncompress::Inflate;
  		    my $output;
  		    my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
  		    my $error = $IO::Uncompress::Inflate::InflateError;
  		    unless ($status) {
  			# "Content-Encoding: deflate" is supposed to mean the
  			# "zlib" format of RFC 1950, but Microsoft got that
  			# wrong, so some servers sends the raw compressed
  			# "deflate" data.  This tries to inflate this format.
  			$output = undef;
  			require IO::Uncompress::RawInflate;
  			unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
  			    $self->push_header("Client-Warning" =>
  				"Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
  			    $output = undef;
  			}
  		    }
  		    die "Can't inflate content: $error" unless defined $output;
  		    $content_ref = \$output;
  		    $content_ref_iscopy++;
  		}
  		elsif ($ce eq "compress" || $ce eq "x-compress") {
  		    die "Can't uncompress content";
  		}
  		elsif ($ce eq "base64") {  # not really C-T-E, but should be harmless
  		    require MIME::Base64;
  		    $content_ref = \MIME::Base64::decode($$content_ref);
  		    $content_ref_iscopy++;
  		}
  		elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
  		    require MIME::QuotedPrint;
  		    $content_ref = \MIME::QuotedPrint::decode($$content_ref);
  		    $content_ref_iscopy++;
  		}
  		else {
  		    die "Don't know how to decode Content-Encoding '$ce'";
  		}
  	    }
  	}
  
  	if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
  	    my $charset = lc(
  	        $opt{charset} ||
  		$self->content_type_charset ||
  		$opt{default_charset} ||
  		$self->content_charset ||
  		"ISO-8859-1"
  	    );
  	    if ($charset eq "none") {
  		# leave it asis
  	    }
  	    elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") {
  		if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) {
  		    unless ($content_ref_iscopy) {
  			my $copy = $$content_ref;
  			$content_ref = \$copy;
  			$content_ref_iscopy++;
  		    }
  		    utf8::upgrade($$content_ref);
  		}
  	    }
  	    else {
  		require Encode;
  		eval {
  		    $content_ref = \Encode::decode($charset, $$content_ref,
  			 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
  		};
  		if ($@) {
  		    my $retried;
  		    if ($@ =~ /^Unknown encoding/) {
  			my $alt_charset = lc($opt{alt_charset} || "");
  			if ($alt_charset && $charset ne $alt_charset) {
  			    # Retry decoding with the alternative charset
  			    $content_ref = \Encode::decode($alt_charset, $$content_ref,
  				 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
  			        unless $alt_charset eq "none";
  			    $retried++;
  			}
  		    }
  		    die unless $retried;
  		}
  		die "Encode::decode() returned undef improperly" unless defined $$content_ref;
  		if ($is_xml) {
  		    # Get rid of the XML encoding declaration if present
  		    $$content_ref =~ s/^\x{FEFF}//;
  		    if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
  			substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
  		    }
  		}
  	    }
  	}
      };
      if ($@) {
  	Carp::croak($@) if $opt{raise_error};
  	return undef;
      }
  
      return $opt{ref} ? $content_ref : $$content_ref;
  }
  
  
  sub decodable
  {
      # should match the Content-Encoding values that decoded_content can deal with
      my $self = shift;
      my @enc;
      # XXX preferably we should determine if the modules are available without loading
      # them here
      eval {
          require IO::Uncompress::Gunzip;
          push(@enc, "gzip", "x-gzip");
      };
      eval {
          require IO::Uncompress::Inflate;
          require IO::Uncompress::RawInflate;
          push(@enc, "deflate");
      };
      eval {
          require IO::Uncompress::Bunzip2;
          push(@enc, "x-bzip2");
      };
      # we don't care about announcing the 'identity', 'base64' and
      # 'quoted-printable' stuff
      return wantarray ? @enc : join(", ", @enc);
  }
  
  
  sub decode
  {
      my $self = shift;
      return 1 unless $self->header("Content-Encoding");
      if (defined(my $content = $self->decoded_content(charset => "none"))) {
  	$self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
  	$self->content($content);
  	return 1;
      }
      return 0;
  }
  
  
  sub encode
  {
      my($self, @enc) = @_;
  
      Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
      Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
  
      return 1 unless @enc;  # nothing to do
  
      my $content = $self->content;
      for my $encoding (@enc) {
  	if ($encoding eq "identity") {
  	    # nothing to do
  	}
  	elsif ($encoding eq "base64") {
  	    require MIME::Base64;
  	    $content = MIME::Base64::encode($content);
  	}
  	elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
  	    require IO::Compress::Gzip;
  	    my $output;
  	    IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
  		or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
  	    $content = $output;
  	}
  	elsif ($encoding eq "deflate") {
  	    require IO::Compress::Deflate;
  	    my $output;
  	    IO::Compress::Deflate::deflate(\$content, \$output)
  		or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
  	    $content = $output;
  	}
  	elsif ($encoding eq "x-bzip2") {
  	    require IO::Compress::Bzip2;
  	    my $output;
  	    IO::Compress::Bzip2::bzip2(\$content, \$output)
  		or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
  	    $content = $output;
  	}
  	elsif ($encoding eq "rot13") {  # for the fun of it
  	    $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
  	}
  	else {
  	    return 0;
  	}
      }
      my $h = $self->header("Content-Encoding");
      unshift(@enc, $h) if $h;
      $self->header("Content-Encoding", join(", ", @enc));
      $self->remove_header("Content-Length", "Content-MD5");
      $self->content($content);
      return 1;
  }
  
  
  sub as_string
  {
      my($self, $eol) = @_;
      $eol = "\n" unless defined $eol;
  
      # The calculation of content might update the headers
      # so we need to do that first.
      my $content = $self->content;
  
      return join("", $self->{'_headers'}->as_string($eol),
  		    $eol,
  		    $content,
  		    (@_ == 1 && length($content) &&
  		     $content !~ /\n\z/) ? "\n" : "",
  		);
  }
  
  
  sub dump
  {
      my($self, %opt) = @_;
      my $content = $self->content;
      my $chopped = 0;
      if (!ref($content)) {
  	my $maxlen = $opt{maxlength};
  	$maxlen = 512 unless defined($maxlen);
  	if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
  	    $chopped = length($content) - $maxlen;
  	    $content = substr($content, 0, $maxlen) . "...";
  	}
  
  	$content =~ s/\\/\\\\/g;
  	$content =~ s/\t/\\t/g;
  	$content =~ s/\r/\\r/g;
  
  	# no need for 3 digits in escape for these
  	$content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  
  	$content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
  	$content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
  
  	# remaining whitespace
  	$content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
  	$content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
  	$content =~ s/\n\z/\\n/;
  
  	my $no_content = $opt{no_content};
  	$no_content = "(no content)" unless defined $no_content;
  	if ($content eq $no_content) {
  	    # escape our $no_content marker
  	    $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
  	}
  	elsif ($content eq "") {
  	    $content = $no_content;
  	}
      }
  
      my @dump;
      push(@dump, $opt{preheader}) if $opt{preheader};
      push(@dump, $self->{_headers}->as_string, $content);
      push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
  
      my $dump = join("\n", @dump, "");
      $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
  
      print $dump unless defined wantarray;
      return $dump;
  }
  
  
  sub parts {
      my $self = shift;
      if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
  	$self->_parts;
      }
      my $old = $self->{_parts};
      if (@_) {
  	my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
  	my $ct = $self->content_type || "";
  	if ($ct =~ m,^message/,) {
  	    Carp::croak("Only one part allowed for $ct content")
  		if @parts > 1;
  	}
  	elsif ($ct !~ m,^multipart/,) {
  	    $self->remove_content_headers;
  	    $self->content_type("multipart/mixed");
  	}
  	$self->{_parts} = \@parts;
  	_stale_content($self);
      }
      return @$old if wantarray;
      return $old->[0];
  }
  
  sub add_part {
      my $self = shift;
      if (($self->content_type || "") !~ m,^multipart/,) {
  	my $p = HTTP::Message->new($self->remove_content_headers,
  				   $self->content(""));
  	$self->content_type("multipart/mixed");
  	$self->{_parts} = [];
          if ($p->headers->header_field_names || $p->content ne "") {
              push(@{$self->{_parts}}, $p);
          }
      }
      elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
  	$self->_parts;
      }
  
      push(@{$self->{_parts}}, @_);
      _stale_content($self);
      return;
  }
  
  sub _stale_content {
      my $self = shift;
      if (ref($self->{_content}) eq "SCALAR") {
  	# must recalculate now
  	$self->_content;
      }
      else {
  	# just invalidate cache
  	delete $self->{_content};
  	delete $self->{_content_ref};
      }
  }
  
  
  # delegate all other method calls the the headers object.
  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 { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) };
      goto &$method;
  }
  
  
  sub DESTROY {}  # avoid AUTOLOADing it
  
  
  # Private method to access members in %$self
  sub _elem
  {
      my $self = shift;
      my $elem = shift;
      my $old = $self->{$elem};
      $self->{$elem} = $_[0] if @_;
      return $old;
  }
  
  
  # Create private _parts attribute from current _content
  sub _parts {
      my $self = shift;
      my $ct = $self->content_type;
      if ($ct =~ m,^multipart/,) {
  	require HTTP::Headers::Util;
  	my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
  	die "Assert" unless @h;
  	my %h = @{$h[0]};
  	if (defined(my $b = $h{boundary})) {
  	    my $str = $self->content;
  	    $str =~ s/\r?\n--\Q$b\E--.*//s;
  	    if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
  		$self->{_parts} = [map HTTP::Message->parse($_),
  				   split(/\r?\n--\Q$b\E\r?\n/, $str)]
  	    }
  	}
      }
      elsif ($ct eq "message/http") {
  	require HTTP::Request;
  	require HTTP::Response;
  	my $content = $self->content;
  	my $class = ($content =~ m,^(HTTP/.*)\n,) ?
  	    "HTTP::Response" : "HTTP::Request";
  	$self->{_parts} = [$class->parse($content)];
      }
      elsif ($ct =~ m,^message/,) {
  	$self->{_parts} = [ HTTP::Message->parse($self->content) ];
      }
  
      $self->{_parts} ||= [];
  }
  
  
  # Create private _content attribute from current _parts
  sub _content {
      my $self = shift;
      my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
      if ($ct =~ m,^\s*message/,i) {
  	_set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
  	return;
      }
  
      require HTTP::Headers::Util;
      my @v = HTTP::Headers::Util::split_header_words($ct);
      Carp::carp("Multiple Content-Type headers") if @v > 1;
      @v = @{$v[0]};
  
      my $boundary;
      my $boundary_index;
      for (my @tmp = @v; @tmp;) {
  	my($k, $v) = splice(@tmp, 0, 2);
  	if ($k eq "boundary") {
  	    $boundary = $v;
  	    $boundary_index = @v - @tmp - 1;
  	    last;
  	}
      }
  
      my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
  
      my $bno = 0;
      $boundary = _boundary() unless defined $boundary;
   CHECK_BOUNDARY:
      {
  	for (@parts) {
  	    if (index($_, $boundary) >= 0) {
  		# must have a better boundary
  		$boundary = _boundary(++$bno);
  		redo CHECK_BOUNDARY;
  	    }
  	}
      }
  
      if ($boundary_index) {
  	$v[$boundary_index] = $boundary;
      }
      else {
  	push(@v, boundary => $boundary);
      }
  
      $ct = HTTP::Headers::Util::join_header_words(@v);
      $self->{_headers}->header("Content-Type", $ct);
  
      _set_content($self, "--$boundary$CRLF" .
  	                join("$CRLF--$boundary$CRLF", @parts) .
  			"$CRLF--$boundary--$CRLF",
                          1);
  }
  
  
  sub _boundary
  {
      my $size = shift || return "xYzZY";
      require MIME::Base64;
      my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
      $b =~ s/[\W]/X/g;  # ensure alnum only
      $b;
  }
  
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  HTTP::Message - HTTP style message (base class)
  
  =head1 SYNOPSIS
  
   use base 'HTTP::Message';
  
  =head1 DESCRIPTION
  
  An C<HTTP::Message> object contains some headers and a content body.
  The following methods are available:
  
  =over 4
  
  =item $mess = HTTP::Message->new
  
  =item $mess = HTTP::Message->new( $headers )
  
  =item $mess = HTTP::Message->new( $headers, $content )
  
  This constructs a new message object.  Normally you would want
  construct C<HTTP::Request> or C<HTTP::Response> objects instead.
  
  The optional $header argument should be a reference to an
  C<HTTP::Headers> object or a plain array reference of key/value pairs.
  If an C<HTTP::Headers> object is provided then a copy of it will be
  embedded into the constructed message, i.e. it will not be owned and
  can be modified afterwards without affecting the message.
  
  The optional $content argument should be a string of bytes.
  
  =item $mess = HTTP::Message->parse( $str )
  
  This constructs a new message object by parsing the given string.
  
  =item $mess->headers
  
  Returns the embedded C<HTTP::Headers> object.
  
  =item $mess->headers_as_string
  
  =item $mess->headers_as_string( $eol )
  
  Call the as_string() method for the headers in the
  message.  This will be the same as
  
      $mess->headers->as_string
  
  but it will make your program a whole character shorter :-)
  
  =item $mess->content
  
  =item $mess->content( $bytes )
  
  The content() method sets the raw content if an argument is given.  If no
  argument is given the content is not touched.  In either case the
  original raw content is returned.
  
  Note that the content should be a string of bytes.  Strings in perl
  can contain characters outside the range of a byte.  The C<Encode>
  module can be used to turn such strings into a string of bytes.
  
  =item $mess->add_content( $bytes )
  
  The add_content() methods appends more data bytes to the end of the
  current content buffer.
  
  =item $mess->add_content_utf8( $string )
  
  The add_content_utf8() method appends the UTF-8 bytes representing the
  string to the end of the current content buffer.
  
  =item $mess->content_ref
  
  =item $mess->content_ref( \$bytes )
  
  The content_ref() method will return a reference to content buffer string.
  It can be more efficient to access the content this way if the content
  is huge, and it can even be used for direct manipulation of the content,
  for instance:
  
    ${$res->content_ref} =~ s/\bfoo\b/bar/g;
  
  This example would modify the content buffer in-place.
  
  If an argument is passed it will setup the content to reference some
  external source.  The content() and add_content() methods
  will automatically dereference scalar references passed this way.  For
  other references content() will return the reference itself and
  add_content() will refuse to do anything.
  
  =item $mess->content_charset
  
  This returns the charset used by the content in the message.  The
  charset is either found as the charset attribute of the
  C<Content-Type> header or by guessing.
  
  See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
  for details about how charset is determined.
  
  =item $mess->decoded_content( %options )
  
  Returns the content with any C<Content-Encoding> undone and for textual content
  the raw content encoded to Perl's Unicode strings.  If the C<Content-Encoding>
  or C<charset> of the message is unknown this method will fail by returning
  C<undef>.
  
  The following options can be specified.
  
  =over
  
  =item C<charset>
  
  This override the charset parameter for text content.  The value
  C<none> can used to suppress decoding of the charset.
  
  =item C<default_charset>
  
  This override the default charset guessed by content_charset() or
  if that fails "ISO-8859-1".
  
  =item C<alt_charset>
  
  If decoding fails because the charset specified in the Content-Type header
  isn't recognized by Perl's Encode module, then try decoding using this charset
  instead of failing.  The C<alt_charset> might be specified as C<none> to simply
  return the string without any decoding of charset as alternative.
  
  =item C<charset_strict>
  
  Abort decoding if malformed characters is found in the content.  By
  default you get the substitution character ("\x{FFFD}") in place of
  malformed characters.
  
  =item C<raise_error>
  
  If TRUE then raise an exception if not able to decode content.  Reason
  might be that the specified C<Content-Encoding> or C<charset> is not
  supported.  If this option is FALSE, then decoded_content() will return
  C<undef> on errors, but will still set $@.
  
  =item C<ref>
  
  If TRUE then a reference to decoded content is returned.  This might
  be more efficient in cases where the decoded content is identical to
  the raw content as no data copying is required in this case.
  
  =back
  
  =item $mess->decodable
  
  =item HTTP::Message::decodable()
  
  This returns the encoding identifiers that decoded_content() can
  process.  In scalar context returns a comma separated string of
  identifiers.
  
  This value is suitable for initializing the C<Accept-Encoding> request
  header field.
  
  =item $mess->decode
  
  This method tries to replace the content of the message with the
  decoded version and removes the C<Content-Encoding> header.  Returns
  TRUE if successful and FALSE if not.
  
  If the message does not have a C<Content-Encoding> header this method
  does nothing and returns TRUE.
  
  Note that the content of the message is still bytes after this method
  has been called and you still need to call decoded_content() if you
  want to process its content as a string.
  
  =item $mess->encode( $encoding, ... )
  
  Apply the given encodings to the content of the message.  Returns TRUE
  if successful. The "identity" (non-)encoding is always supported; other
  currently supported encodings, subject to availability of required
  additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
  
  A successful call to this function will set the C<Content-Encoding>
  header.
  
  Note that C<multipart/*> or C<message/*> messages can't be encoded and
  this method will croak if you try.
  
  =item $mess->parts
  
  =item $mess->parts( @parts )
  
  =item $mess->parts( \@parts )
  
  Messages can be composite, i.e. contain other messages.  The composite
  messages have a content type of C<multipart/*> or C<message/*>.  This
  method give access to the contained messages.
  
  The argumentless form will return a list of C<HTTP::Message> objects.
  If the content type of $msg is not C<multipart/*> or C<message/*> then
  this will return the empty list.  In scalar context only the first
  object is returned.  The returned message parts should be regarded as
  read-only (future versions of this library might make it possible
  to modify the parent by modifying the parts).
  
  If the content type of $msg is C<message/*> then there will only be
  one part returned.
  
  If the content type is C<message/http>, then the return value will be
  either an C<HTTP::Request> or an C<HTTP::Response> object.
  
  If a @parts argument is given, then the content of the message will be
  modified. The array reference form is provided so that an empty list
  can be provided.  The @parts array should contain C<HTTP::Message>
  objects.  The @parts objects are owned by $mess after this call and
  should not be modified or made part of other messages.
  
  When updating the message with this method and the old content type of
  $mess is not C<multipart/*> or C<message/*>, then the content type is
  set to C<multipart/mixed> and all other content headers are cleared.
  
  This method will croak if the content type is C<message/*> and more
  than one part is provided.
  
  =item $mess->add_part( $part )
  
  This will add a part to a message.  The $part argument should be
  another C<HTTP::Message> object.  If the previous content type of
  $mess is not C<multipart/*> then the old content (together with all
  content headers) will be made part #1 and the content type made
  C<multipart/mixed> before the new part is added.  The $part object is
  owned by $mess after this call and should not be modified or made part
  of other messages.
  
  There is no return value.
  
  =item $mess->clear
  
  Will clear the headers and set the content to the empty string.  There
  is no return value
  
  =item $mess->protocol
  
  =item $mess->protocol( $proto )
  
  Sets the HTTP protocol used for the message.  The protocol() is a string
  like C<HTTP/1.0> or C<HTTP/1.1>.
  
  =item $mess->clone
  
  Returns a copy of the message object.
  
  =item $mess->as_string
  
  =item $mess->as_string( $eol )
  
  Returns the message formatted as a single string.
  
  The optional $eol parameter specifies the line ending sequence to use.
  The default is "\n".  If no $eol is given then as_string will ensure
  that the returned string is newline terminated (even when the message
  content is not).  No extra newline is appended if an explicit $eol is
  passed.
  
  =item $mess->dump( %opt )
  
  Returns the message formatted as a string.  In void context print the string.
  
  This differs from C<< $mess->as_string >> in that it escapes the bytes
  of the content so that it's safe to print them and it limits how much
  content to print.  The escapes syntax used is the same as for Perl's
  double quoted strings.  If there is no content the string "(no
  content)" is shown in its place.
  
  Options to influence the output can be passed as key/value pairs. The
  following options are recognized:
  
  =over
  
  =item maxlength => $num
  
  How much of the content to show.  The default is 512.  Set this to 0
  for unlimited.
  
  If the content is longer then the string is chopped at the limit and
  the string "...\n(### more bytes not shown)" appended.
  
  =item no_content => $str
  
  Replaces the "(no content)" marker.
  
  =item prefix => $str
  
  A string that will be prefixed to each line of the dump.
  
  =back
  
  =back
  
  All methods unknown to C<HTTP::Message> itself are delegated to the
  C<HTTP::Headers> object that is part of every message.  This allows
  convenient access to these methods.  Refer to L<HTTP::Headers> for
  details of these methods:
  
      $mess->header( $field => $val )
      $mess->push_header( $field => $val )
      $mess->init_header( $field => $val )
      $mess->remove_header( $field )
      $mess->remove_content_headers
      $mess->header_field_names
      $mess->scan( \&doit )
  
      $mess->date
      $mess->expires
      $mess->if_modified_since
      $mess->if_unmodified_since
      $mess->last_modified
      $mess->content_type
      $mess->content_encoding
      $mess->content_length
      $mess->content_language
      $mess->title
      $mess->user_agent
      $mess->server
      $mess->from
      $mess->referer
      $mess->www_authenticate
      $mess->authorization
      $mess->proxy_authorization
      $mess->authorization_basic
      $mess->proxy_authorization_basic
  
  =head1 COPYRIGHT
  
  Copyright 1995-2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
HTTP_MESSAGE

$fatpacked{"HTTP/Request.pm"} = <<'HTTP_REQUEST';
  package HTTP::Request;
  
  require HTTP::Message;
  @ISA = qw(HTTP::Message);
  $VERSION = "6.00";
  
  use strict;
  
  
  
  sub new
  {
      my($class, $method, $uri, $header, $content) = @_;
      my $self = $class->SUPER::new($header, $content);
      $self->method($method);
      $self->uri($uri);
      $self;
  }
  
  
  sub parse
  {
      my($class, $str) = @_;
      my $request_line;
      if ($str =~ s/^(.*)\n//) {
  	$request_line = $1;
      }
      else {
  	$request_line = $str;
  	$str = "";
      }
  
      my $self = $class->SUPER::parse($str);
      my($method, $uri, $protocol) = split(' ', $request_line);
      $self->method($method) if defined($method);
      $self->uri($uri) if defined($uri);
      $self->protocol($protocol) if $protocol;
      $self;
  }
  
  
  sub clone
  {
      my $self = shift;
      my $clone = bless $self->SUPER::clone, ref($self);
      $clone->method($self->method);
      $clone->uri($self->uri);
      $clone;
  }
  
  
  sub method
  {
      shift->_elem('_method', @_);
  }
  
  
  sub uri
  {
      my $self = shift;
      my $old = $self->{'_uri'};
      if (@_) {
  	my $uri = shift;
  	if (!defined $uri) {
  	    # that's ok
  	}
  	elsif (ref $uri) {
  	    Carp::croak("A URI can't be a " . ref($uri) . " reference")
  		if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
  	    Carp::croak("Can't use a " . ref($uri) . " object as a URI")
  		unless $uri->can('scheme');
  	    $uri = $uri->clone;
  	    unless ($HTTP::URI_CLASS eq "URI") {
  		# Argh!! Hate this... old LWP legacy!
  		eval { local $SIG{__DIE__}; $uri = $uri->abs; };
  		die $@ if $@ && $@ !~ /Missing base argument/;
  	    }
  	}
  	else {
  	    $uri = $HTTP::URI_CLASS->new($uri);
  	}
  	$self->{'_uri'} = $uri;
          delete $self->{'_uri_canonical'};
      }
      $old;
  }
  
  *url = \&uri;  # legacy
  
  sub uri_canonical
  {
      my $self = shift;
      return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
  }
  
  
  sub accept_decodable
  {
      my $self = shift;
      $self->header("Accept-Encoding", scalar($self->decodable));
  }
  
  sub as_string
  {
      my $self = shift;
      my($eol) = @_;
      $eol = "\n" unless defined $eol;
  
      my $req_line = $self->method || "-";
      my $uri = $self->uri;
      $uri = (defined $uri) ? $uri->as_string : "-";
      $req_line .= " $uri";
      my $proto = $self->protocol;
      $req_line .= " $proto" if $proto;
  
      return join($eol, $req_line, $self->SUPER::as_string(@_));
  }
  
  sub dump
  {
      my $self = shift;
      my @pre = ($self->method || "-", $self->uri || "-");
      if (my $prot = $self->protocol) {
  	push(@pre, $prot);
      }
  
      return $self->SUPER::dump(
          preheader => join(" ", @pre),
  	@_,
      );
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Request - HTTP style request message
  
  =head1 SYNOPSIS
  
   require HTTP::Request;
   $request = HTTP::Request->new(GET => 'http://www.example.com/');
  
  and usually used like this:
  
   $ua = LWP::UserAgent->new;
   $response = $ua->request($request);
  
  =head1 DESCRIPTION
  
  C<HTTP::Request> is a class encapsulating HTTP style requests,
  consisting of a request line, some headers, and a content body. Note
  that the LWP library uses HTTP style requests even for non-HTTP
  protocols.  Instances of this class are usually passed to the
  request() method of an C<LWP::UserAgent> object.
  
  C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
  inherits its methods.  The following additional methods are available:
  
  =over 4
  
  =item $r = HTTP::Request->new( $method, $uri )
  
  =item $r = HTTP::Request->new( $method, $uri, $header )
  
  =item $r = HTTP::Request->new( $method, $uri, $header, $content )
  
  Constructs a new C<HTTP::Request> object describing a request on the
  object $uri using method $method.  The $method argument must be a
  string.  The $uri argument can be either a string, or a reference to a
  C<URI> object.  The optional $header argument should be a reference to
  an C<HTTP::Headers> object or a plain array reference of key/value
  pairs.  The optional $content argument should be a string of bytes.
  
  =item $r = HTTP::Request->parse( $str )
  
  This constructs a new request object by parsing the given string.
  
  =item $r->method
  
  =item $r->method( $val )
  
  This is used to get/set the method attribute.  The method should be a
  short string like "GET", "HEAD", "PUT" or "POST".
  
  =item $r->uri
  
  =item $r->uri( $val )
  
  This is used to get/set the uri attribute.  The $val can be a
  reference to a URI object or a plain string.  If a string is given,
  then it should be parseable as an absolute URI.
  
  =item $r->header( $field )
  
  =item $r->header( $field => $value )
  
  This is used to get/set header values and it is inherited from
  C<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> for
  details and other similar methods that can be used to access the
  headers.
  
  =item $r->accept_decodable
  
  This will set the C<Accept-Encoding> header to the list of encodings
  that decoded_content() can decode.
  
  =item $r->content
  
  =item $r->content( $bytes )
  
  This is used to get/set the content and it is inherited from the
  C<HTTP::Message> base class.  See L<HTTP::Message> for details and
  other methods that can be used to access the content.
  
  Note that the content should be a string of bytes.  Strings in perl
  can contain characters outside the range of a byte.  The C<Encode>
  module can be used to turn such strings into a string of bytes.
  
  =item $r->as_string
  
  =item $r->as_string( $eol )
  
  Method returning a textual representation of the request.
  
  =back
  
  =head1 SEE ALSO
  
  L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
  L<HTTP::Response>
  
  =head1 COPYRIGHT
  
  Copyright 1995-2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
HTTP_REQUEST

$fatpacked{"HTTP/Request/Common.pm"} = <<'HTTP_REQUEST_COMMON';
  package HTTP::Request::Common;
  
  use strict;
  use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
  
  $DYNAMIC_FILE_UPLOAD ||= 0;  # make it defined (don't know why)
  
  require Exporter;
  *import = \&Exporter::import;
  @EXPORT =qw(GET HEAD PUT POST);
  @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
  
  require HTTP::Request;
  use Carp();
  
  $VERSION = "6.04";
  
  my $CRLF = "\015\012";   # "\r\n" is not portable
  
  sub GET  { _simple_req('GET',  @_); }
  sub HEAD { _simple_req('HEAD', @_); }
  sub PUT  { _simple_req('PUT' , @_); }
  sub DELETE { _simple_req('DELETE', @_); }
  
  sub POST
  {
      my $url = shift;
      my $req = HTTP::Request->new(POST => $url);
      my $content;
      $content = shift if @_ and ref $_[0];
      my($k, $v);
      while (($k,$v) = splice(@_, 0, 2)) {
  	if (lc($k) eq 'content') {
  	    $content = $v;
  	}
  	else {
  	    $req->push_header($k, $v);
  	}
      }
      my $ct = $req->header('Content-Type');
      unless ($ct) {
  	$ct = 'application/x-www-form-urlencoded';
      }
      elsif ($ct eq 'form-data') {
  	$ct = 'multipart/form-data';
      }
  
      if (ref $content) {
  	if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
  	    require HTTP::Headers::Util;
  	    my @v = HTTP::Headers::Util::split_header_words($ct);
  	    Carp::carp("Multiple Content-Type headers") if @v > 1;
  	    @v = @{$v[0]};
  
  	    my $boundary;
  	    my $boundary_index;
  	    for (my @tmp = @v; @tmp;) {
  		my($k, $v) = splice(@tmp, 0, 2);
  		if ($k eq "boundary") {
  		    $boundary = $v;
  		    $boundary_index = @v - @tmp - 1;
  		    last;
  		}
  	    }
  
  	    ($content, $boundary) = form_data($content, $boundary, $req);
  
  	    if ($boundary_index) {
  		$v[$boundary_index] = $boundary;
  	    }
  	    else {
  		push(@v, boundary => $boundary);
  	    }
  
  	    $ct = HTTP::Headers::Util::join_header_words(@v);
  	}
  	else {
  	    # We use a temporary URI object to format
  	    # the application/x-www-form-urlencoded content.
  	    require URI;
  	    my $url = URI->new('http:');
  	    $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
  	    $content = $url->query;
  
  	    # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A')
  	    $content =~ s/(?<!%0D)%0A/%0D%0A/g if defined($content);
  	}
      }
  
      $req->header('Content-Type' => $ct);  # might be redundant
      if (defined($content)) {
  	$req->header('Content-Length' =>
  		     length($content)) unless ref($content);
  	$req->content($content);
      }
      else {
          $req->header('Content-Length' => 0);
      }
      $req;
  }
  
  
  sub _simple_req
  {
      my($method, $url) = splice(@_, 0, 2);
      my $req = HTTP::Request->new($method => $url);
      my($k, $v);
      my $content;
      while (($k,$v) = splice(@_, 0, 2)) {
  	if (lc($k) eq 'content') {
  	    $req->add_content($v);
              $content++;
  	}
  	else {
  	    $req->push_header($k, $v);
  	}
      }
      if ($content && !defined($req->header("Content-Length"))) {
          $req->header("Content-Length", length(${$req->content_ref}));
      }
      $req;
  }
  
  
  sub form_data   # RFC1867
  {
      my($data, $boundary, $req) = @_;
      my @data = ref($data) eq "HASH" ? %$data : @$data;  # copy
      my $fhparts;
      my @parts;
      my($k,$v);
      while (($k,$v) = splice(@data, 0, 2)) {
  	if (!ref($v)) {
  	    $k =~ s/([\\\"])/\\$1/g;  # escape quotes and backslashes
  	    push(@parts,
  		 qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
  	}
  	else {
  	    my($file, $usename, @headers) = @$v;
  	    unless (defined $usename) {
  		$usename = $file;
  		$usename =~ s,.*/,, if defined($usename);
  	    }
              $k =~ s/([\\\"])/\\$1/g;
  	    my $disp = qq(form-data; name="$k");
              if (defined($usename) and length($usename)) {
                  $usename =~ s/([\\\"])/\\$1/g;
                  $disp .= qq(; filename="$usename");
              }
  	    my $content = "";
  	    my $h = HTTP::Headers->new(@headers);
  	    if ($file) {
  		open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
  		binmode($fh);
  		if ($DYNAMIC_FILE_UPLOAD) {
  		    # will read file later, close it now in order to
                      # not accumulate to many open file handles
                      close($fh);
  		    $content = \$file;
  		}
  		else {
  		    local($/) = undef; # slurp files
  		    $content = <$fh>;
  		    close($fh);
  		}
  		unless ($h->header("Content-Type")) {
  		    require LWP::MediaTypes;
  		    LWP::MediaTypes::guess_media_type($file, $h);
  		}
  	    }
  	    if ($h->header("Content-Disposition")) {
  		# just to get it sorted first
  		$disp = $h->header("Content-Disposition");
  		$h->remove_header("Content-Disposition");
  	    }
  	    if ($h->header("Content")) {
  		$content = $h->header("Content");
  		$h->remove_header("Content");
  	    }
  	    my $head = join($CRLF, "Content-Disposition: $disp",
  			           $h->as_string($CRLF),
  			           "");
  	    if (ref $content) {
  		push(@parts, [$head, $$content]);
  		$fhparts++;
  	    }
  	    else {
  		push(@parts, $head . $content);
  	    }
  	}
      }
      return ("", "none") unless @parts;
  
      my $content;
      if ($fhparts) {
  	$boundary = boundary(10) # hopefully enough randomness
  	    unless $boundary;
  
  	# add the boundaries to the @parts array
  	for (1..@parts-1) {
  	    splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
  	}
  	unshift(@parts, "--$boundary$CRLF");
  	push(@parts, "$CRLF--$boundary--$CRLF");
  
  	# See if we can generate Content-Length header
  	my $length = 0;
  	for (@parts) {
  	    if (ref $_) {
  	 	my ($head, $f) = @$_;
  		my $file_size;
  		unless ( -f $f && ($file_size = -s _) ) {
  		    # The file is either a dynamic file like /dev/audio
  		    # or perhaps a file in the /proc file system where
  		    # stat may return a 0 size even though reading it
  		    # will produce data.  So we cannot make
  		    # a Content-Length header.  
  		    undef $length;
  		    last;
  		}
  	    	$length += $file_size + length $head;
  	    }
  	    else {
  		$length += length;
  	    }
          }
          $length && $req->header('Content-Length' => $length);
  
  	# set up a closure that will return content piecemeal
  	$content = sub {
  	    for (;;) {
  		unless (@parts) {
  		    defined $length && $length != 0 &&
  		    	Carp::croak "length of data sent did not match calculated Content-Length header.  Probably because uploaded file changed in size during transfer.";
  		    return;
  		}
  		my $p = shift @parts;
  		unless (ref $p) {
  		    $p .= shift @parts while @parts && !ref($parts[0]);
  		    defined $length && ($length -= length $p);
  		    return $p;
  		}
  		my($buf, $fh) = @$p;
                  unless (ref($fh)) {
                      my $file = $fh;
                      undef($fh);
                      open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
                      binmode($fh);
                  }
  		my $buflength = length $buf;
  		my $n = read($fh, $buf, 2048, $buflength);
  		if ($n) {
  		    $buflength += $n;
  		    unshift(@parts, ["", $fh]);
  		}
  		else {
  		    close($fh);
  		}
  		if ($buflength) {
  		    defined $length && ($length -= $buflength);
  		    return $buf 
  	    	}
  	    }
  	};
  
      }
      else {
  	$boundary = boundary() unless $boundary;
  
  	my $bno = 0;
        CHECK_BOUNDARY:
  	{
  	    for (@parts) {
  		if (index($_, $boundary) >= 0) {
  		    # must have a better boundary
  		    $boundary = boundary(++$bno);
  		    redo CHECK_BOUNDARY;
  		}
  	    }
  	    last;
  	}
  	$content = "--$boundary$CRLF" .
  	           join("$CRLF--$boundary$CRLF", @parts) .
  		   "$CRLF--$boundary--$CRLF";
      }
  
      wantarray ? ($content, $boundary) : $content;
  }
  
  
  sub boundary
  {
      my $size = shift || return "xYzZY";
      require MIME::Base64;
      my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
      $b =~ s/[\W]/X/g;  # ensure alnum only
      $b;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Request::Common - Construct common HTTP::Request objects
  
  =head1 SYNOPSIS
  
    use HTTP::Request::Common;
    $ua = LWP::UserAgent->new;
    $ua->request(GET 'http://www.sn.no/');
    $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
  
  =head1 DESCRIPTION
  
  This module provide functions that return newly created C<HTTP::Request>
  objects.  These functions are usually more convenient to use than the
  standard C<HTTP::Request> constructor for the most common requests.  The
  following functions are provided:
  
  =over 4
  
  =item GET $url
  
  =item GET $url, Header => Value,...
  
  The GET() function returns an C<HTTP::Request> object initialized with
  the "GET" method and the specified URL.  It is roughly equivalent to the
  following call
  
    HTTP::Request->new(
       GET => $url,
       HTTP::Headers->new(Header => Value,...),
    )
  
  but is less cluttered.  What is different is that a header named
  C<Content> will initialize the content part of the request instead of
  setting a header field.  Note that GET requests should normally not
  have a content, so this hack makes more sense for the PUT() and POST()
  functions described below.
  
  The get(...) method of C<LWP::UserAgent> exists as a shortcut for
  $ua->request(GET ...).
  
  =item HEAD $url
  
  =item HEAD $url, Header => Value,...
  
  Like GET() but the method in the request is "HEAD".
  
  The head(...)  method of "LWP::UserAgent" exists as a shortcut for
  $ua->request(HEAD ...).
  
  =item PUT $url
  
  =item PUT $url, Header => Value,...
  
  =item PUT $url, Header => Value,..., Content => $content
  
  Like GET() but the method in the request is "PUT".
  
  The content of the request can be specified using the "Content"
  pseudo-header.  This steals a bit of the header field namespace as
  there is no way to directly specify a header that is actually called
  "Content".  If you really need this you must update the request
  returned in a separate statement.
  
  =item DELETE $url
  
  =item DELETE $url, Header => Value,...
  
  Like GET() but the method in the request is "DELETE".  This function
  is not exported by default.
  
  =item POST $url
  
  =item POST $url, Header => Value,...
  
  =item POST $url, $form_ref, Header => Value,...
  
  =item POST $url, Header => Value,..., Content => $form_ref
  
  =item POST $url, Header => Value,..., Content => $content
  
  This works mostly like PUT() with "POST" as the method, but this
  function also takes a second optional array or hash reference
  parameter $form_ref.  As for PUT() the content can also be specified
  directly using the "Content" pseudo-header, and you may also provide
  the $form_ref this way.
  
  The $form_ref argument can be used to pass key/value pairs for the
  form content.  By default we will initialize a request using the
  C<application/x-www-form-urlencoded> content type.  This means that
  you can emulate an HTML E<lt>form> POSTing like this:
  
    POST 'http://www.perl.org/survey.cgi',
         [ name   => 'Gisle Aas',
           email  => 'gisle@aas.no',
           gender => 'M',
           born   => '1964',
           perc   => '3%',
         ];
  
  This will create an HTTP::Request object that looks like this:
  
    POST http://www.perl.org/survey.cgi
    Content-Length: 66
    Content-Type: application/x-www-form-urlencoded
  
    name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
  
  Multivalued form fields can be specified by either repeating the field
  name or by passing the value as an array reference.
  
  The POST method also supports the C<multipart/form-data> content used
  for I<Form-based File Upload> as specified in RFC 1867.  You trigger
  this content format by specifying a content type of C<'form-data'> as
  one of the request headers.  If one of the values in the $form_ref is
  an array reference, then it is treated as a file part specification
  with the following interpretation:
  
    [ $file, $filename, Header => Value... ]
    [ undef, $filename, Header => Value,..., Content => $content ]
  
  The first value in the array ($file) is the name of a file to open.
  This file will be read and its content placed in the request.  The
  routine will croak if the file can't be opened.  Use an C<undef> as
  $file value if you want to specify the content directly with a
  C<Content> header.  The $filename is the filename to report in the
  request.  If this value is undefined, then the basename of the $file
  will be used.  You can specify an empty string as $filename if you
  want to suppress sending the filename when you provide a $file value.
  
  If a $file is provided by no C<Content-Type> header, then C<Content-Type>
  and C<Content-Encoding> will be filled in automatically with the values
  returned by LWP::MediaTypes::guess_media_type()
  
  Sending my F<~/.profile> to the survey used as example above can be
  achieved by this:
  
    POST 'http://www.perl.org/survey.cgi',
         Content_Type => 'form-data',
         Content      => [ name  => 'Gisle Aas',
                           email => 'gisle@aas.no',
                           gender => 'M',
                           born   => '1964',
                           init   => ["$ENV{HOME}/.profile"],
                         ]
  
  This will create an HTTP::Request object that almost looks this (the
  boundary and the content of your F<~/.profile> is likely to be
  different):
  
    POST http://www.perl.org/survey.cgi
    Content-Length: 388
    Content-Type: multipart/form-data; boundary="6G+f"
  
    --6G+f
    Content-Disposition: form-data; name="name"
  
    Gisle Aas
    --6G+f
    Content-Disposition: form-data; name="email"
  
    gisle@aas.no
    --6G+f
    Content-Disposition: form-data; name="gender"
  
    M
    --6G+f
    Content-Disposition: form-data; name="born"
  
    1964
    --6G+f
    Content-Disposition: form-data; name="init"; filename=".profile"
    Content-Type: text/plain
  
    PATH=/local/perl/bin:$PATH
    export PATH
  
    --6G+f--
  
  If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
  value, then you get back a request object with a subroutine closure as
  the content attribute.  This subroutine will read the content of any
  files on demand and return it in suitable chunks.  This allow you to
  upload arbitrary big files without using lots of memory.  You can even
  upload infinite files like F</dev/audio> if you wish; however, if
  the file is not a plain file, there will be no Content-Length header
  defined for the request.  Not all servers (or server
  applications) like this.  Also, if the file(s) change in size between
  the time the Content-Length is calculated and the time that the last
  chunk is delivered, the subroutine will C<Croak>.
  
  The post(...)  method of "LWP::UserAgent" exists as a shortcut for
  $ua->request(POST ...).
  
  =back
  
  =head1 SEE ALSO
  
  L<HTTP::Request>, L<LWP::UserAgent>
  
  
  =head1 COPYRIGHT
  
  Copyright 1997-2004, Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
  
HTTP_REQUEST_COMMON

$fatpacked{"HTTP/Response.pm"} = <<'HTTP_RESPONSE';
  package HTTP::Response;
  
  require HTTP::Message;
  @ISA = qw(HTTP::Message);
  $VERSION = "6.04";
  
  use strict;
  use HTTP::Status ();
  
  
  
  sub new
  {
      my($class, $rc, $msg, $header, $content) = @_;
      my $self = $class->SUPER::new($header, $content);
      $self->code($rc);
      $self->message($msg);
      $self;
  }
  
  
  sub parse
  {
      my($class, $str) = @_;
      my $status_line;
      if ($str =~ s/^(.*)\n//) {
  	$status_line = $1;
      }
      else {
  	$status_line = $str;
  	$str = "";
      }
  
      my $self = $class->SUPER::parse($str);
      my($protocol, $code, $message);
      if ($status_line =~ /^\d{3} /) {
         # Looks like a response created by HTTP::Response->new
         ($code, $message) = split(' ', $status_line, 2);
      } else {
         ($protocol, $code, $message) = split(' ', $status_line, 3);
      }
      $self->protocol($protocol) if $protocol;
      $self->code($code) if defined($code);
      $self->message($message) if defined($message);
      $self;
  }
  
  
  sub clone
  {
      my $self = shift;
      my $clone = bless $self->SUPER::clone, ref($self);
      $clone->code($self->code);
      $clone->message($self->message);
      $clone->request($self->request->clone) if $self->request;
      # we don't clone previous
      $clone;
  }
  
  
  sub code      { shift->_elem('_rc',      @_); }
  sub message   { shift->_elem('_msg',     @_); }
  sub previous  { shift->_elem('_previous',@_); }
  sub request   { shift->_elem('_request', @_); }
  
  
  sub status_line
  {
      my $self = shift;
      my $code = $self->{'_rc'}  || "000";
      my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
      return "$code $mess";
  }
  
  
  sub base
  {
      my $self = shift;
      my $base = (
  	$self->header('Content-Base'),        # used to be HTTP/1.1
  	$self->header('Content-Location'),    # HTTP/1.1
  	$self->header('Base'),                # HTTP/1.0
      )[0];
      if ($base && $base =~ /^$URI::scheme_re:/o) {
  	# already absolute
  	return $HTTP::URI_CLASS->new($base);
      }
  
      my $req = $self->request;
      if ($req) {
          # if $base is undef here, the return value is effectively
          # just a copy of $self->request->uri.
          return $HTTP::URI_CLASS->new_abs($base, $req->uri);
      }
  
      # can't find an absolute base
      return undef;
  }
  
  
  sub redirects {
      my $self = shift;
      my @r;
      my $r = $self;
      while (my $p = $r->previous) {
          push(@r, $p);
          $r = $p;
      }
      return @r unless wantarray;
      return reverse @r;
  }
  
  
  sub filename
  {
      my $self = shift;
      my $file;
  
      my $cd = $self->header('Content-Disposition');
      if ($cd) {
  	require HTTP::Headers::Util;
  	if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
  	    my ($disposition, undef, %cd_param) = @{$cd[-1]};
  	    $file = $cd_param{filename};
  
  	    # RFC 2047 encoded?
  	    if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
  		my $charset = $1;
  		my $encoding = uc($2);
  		my $encfile = $3;
  
  		if ($encoding eq 'Q' || $encoding eq 'B') {
  		    local($SIG{__DIE__});
  		    eval {
  			if ($encoding eq 'Q') {
  			    $encfile =~ s/_/ /g;
  			    require MIME::QuotedPrint;
  			    $encfile = MIME::QuotedPrint::decode($encfile);
  			}
  			else { # $encoding eq 'B'
  			    require MIME::Base64;
  			    $encfile = MIME::Base64::decode($encfile);
  			}
  
  			require Encode;
  			require Encode::Locale;
  			Encode::from_to($encfile, $charset, "locale_fs");
  		    };
  
  		    $file = $encfile unless $@;
  		}
  	    }
  	}
      }
  
      unless (defined($file) && length($file)) {
  	my $uri;
  	if (my $cl = $self->header('Content-Location')) {
  	    $uri = URI->new($cl);
  	}
  	elsif (my $request = $self->request) {
  	    $uri = $request->uri;
  	}
  
  	if ($uri) {
  	    $file = ($uri->path_segments)[-1];
  	}
      }
  
      if ($file) {
  	$file =~ s,.*[\\/],,;  # basename
      }
  
      if ($file && !length($file)) {
  	$file = undef;
      }
  
      $file;
  }
  
  
  sub as_string
  {
      my $self = shift;
      my($eol) = @_;
      $eol = "\n" unless defined $eol;
  
      my $status_line = $self->status_line;
      my $proto = $self->protocol;
      $status_line = "$proto $status_line" if $proto;
  
      return join($eol, $status_line, $self->SUPER::as_string(@_));
  }
  
  
  sub dump
  {
      my $self = shift;
  
      my $status_line = $self->status_line;
      my $proto = $self->protocol;
      $status_line = "$proto $status_line" if $proto;
  
      return $self->SUPER::dump(
  	preheader => $status_line,
          @_,
      );
  }
  
  
  sub is_info     { HTTP::Status::is_info     (shift->{'_rc'}); }
  sub is_success  { HTTP::Status::is_success  (shift->{'_rc'}); }
  sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
  sub is_error    { HTTP::Status::is_error    (shift->{'_rc'}); }
  
  
  sub error_as_HTML
  {
      my $self = shift;
      my $title = 'An Error Occurred';
      my $body  = $self->status_line;
      $body =~ s/&/&amp;/g;
      $body =~ s/</&lt;/g;
      return <<EOM;
  <html>
  <head><title>$title</title></head>
  <body>
  <h1>$title</h1>
  <p>$body</p>
  </body>
  </html>
  EOM
  }
  
  
  sub current_age
  {
      my $self = shift;
      my $time = shift;
  
      # Implementation of RFC 2616 section 13.2.3
      # (age calculations)
      my $response_time = $self->client_date;
      my $date = $self->date;
  
      my $age = 0;
      if ($response_time && $date) {
  	$age = $response_time - $date;  # apparent_age
  	$age = 0 if $age < 0;
      }
  
      my $age_v = $self->header('Age');
      if ($age_v && $age_v > $age) {
  	$age = $age_v;   # corrected_received_age
      }
  
      if ($response_time) {
  	my $request = $self->request;
  	if ($request) {
  	    my $request_time = $request->date;
  	    if ($request_time && $request_time < $response_time) {
  		# Add response_delay to age to get 'corrected_initial_age'
  		$age += $response_time - $request_time;
  	    }
  	}
  	$age += ($time || time) - $response_time;
      }
      return $age;
  }
  
  
  sub freshness_lifetime
  {
      my($self, %opt) = @_;
  
      # First look for the Cache-Control: max-age=n header
      for my $cc ($self->header('Cache-Control')) {
  	for my $cc_dir (split(/\s*,\s*/, $cc)) {
  	    return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
  	}
      }
  
      # Next possibility is to look at the "Expires" header
      my $date = $self->date || $self->client_date || $opt{time} || time;
      if (my $expires = $self->expires) {
  	return $expires - $date;
      }
  
      # Must apply heuristic expiration
      return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
  
      # Default heuristic expiration parameters
      $opt{h_min} ||= 60;
      $opt{h_max} ||= 24 * 3600;
      $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
      $opt{h_default} ||= 3600;
  
      # Should give a warning if more than 24 hours according to
      # RFC 2616 section 13.2.4.  Here we just make this the default
      # maximum value.
  
      if (my $last_modified = $self->last_modified) {
  	my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
  	return $opt{h_min} if $h_exp < $opt{h_min};
  	return $opt{h_max} if $h_exp > $opt{h_max};
  	return $h_exp;
      }
  
      # default when all else fails
      return $opt{h_min} if $opt{h_min} > $opt{h_default};
      return $opt{h_default};
  }
  
  
  sub is_fresh
  {
      my($self, %opt) = @_;
      $opt{time} ||= time;
      my $f = $self->freshness_lifetime(%opt);
      return undef unless defined($f);
      return $f > $self->current_age($opt{time});
  }
  
  
  sub fresh_until
  {
      my($self, %opt) = @_;
      $opt{time} ||= time;
      my $f = $self->freshness_lifetime(%opt);
      return undef unless defined($f);
      return $f - $self->current_age($opt{time}) + $opt{time};
  }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  HTTP::Response - HTTP style response message
  
  =head1 SYNOPSIS
  
  Response objects are returned by the request() method of the C<LWP::UserAgent>:
  
      # ...
      $response = $ua->request($request)
      if ($response->is_success) {
          print $response->decoded_content;
      }
      else {
          print STDERR $response->status_line, "\n";
      }
  
  =head1 DESCRIPTION
  
  The C<HTTP::Response> class encapsulates HTTP style responses.  A
  response consists of a response line, some headers, and a content
  body. Note that the LWP library uses HTTP style responses even for
  non-HTTP protocol schemes.  Instances of this class are usually
  created and returned by the request() method of an C<LWP::UserAgent>
  object.
  
  C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
  inherits its methods.  The following additional methods are available:
  
  =over 4
  
  =item $r = HTTP::Response->new( $code )
  
  =item $r = HTTP::Response->new( $code, $msg )
  
  =item $r = HTTP::Response->new( $code, $msg, $header )
  
  =item $r = HTTP::Response->new( $code, $msg, $header, $content )
  
  Constructs a new C<HTTP::Response> object describing a response with
  response code $code and optional message $msg.  The optional $header
  argument should be a reference to an C<HTTP::Headers> object or a
  plain array reference of key/value pairs.  The optional $content
  argument should be a string of bytes.  The meanings of these arguments are
  described below.
  
  =item $r = HTTP::Response->parse( $str )
  
  This constructs a new response object by parsing the given string.
  
  =item $r->code
  
  =item $r->code( $code )
  
  This is used to get/set the code attribute.  The code is a 3 digit
  number that encode the overall outcome of an HTTP response.  The
  C<HTTP::Status> module provide constants that provide mnemonic names
  for the code attribute.
  
  =item $r->message
  
  =item $r->message( $message )
  
  This is used to get/set the message attribute.  The message is a short
  human readable single line string that explains the response code.
  
  =item $r->header( $field )
  
  =item $r->header( $field => $value )
  
  This is used to get/set header values and it is inherited from
  C<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> for
  details and other similar methods that can be used to access the
  headers.
  
  =item $r->content
  
  =item $r->content( $bytes )
  
  This is used to get/set the raw content and it is inherited from the
  C<HTTP::Message> base class.  See L<HTTP::Message> for details and
  other methods that can be used to access the content.
  
  =item $r->decoded_content( %options )
  
  This will return the content after any C<Content-Encoding> and
  charsets have been decoded.  See L<HTTP::Message> for details.
  
  =item $r->request
  
  =item $r->request( $request )
  
  This is used to get/set the request attribute.  The request attribute
  is a reference to the the request that caused this response.  It does
  not have to be the same request passed to the $ua->request() method,
  because there might have been redirects and authorization retries in
  between.
  
  =item $r->previous
  
  =item $r->previous( $response )
  
  This is used to get/set the previous attribute.  The previous
  attribute is used to link together chains of responses.  You get
  chains of responses if the first response is redirect or unauthorized.
  The value is C<undef> if this is the first response in a chain.
  
  Note that the method $r->redirects is provided as a more convenient
  way to access the response chain.
  
  =item $r->status_line
  
  Returns the string "E<lt>code> E<lt>message>".  If the message attribute
  is not set then the official name of E<lt>code> (see L<HTTP::Status>)
  is substituted.
  
  =item $r->base
  
  Returns the base URI for this response.  The return value will be a
  reference to a URI object.
  
  The base URI is obtained from one the following sources (in priority
  order):
  
  =over 4
  
  =item 1.
  
  Embedded in the document content, for instance <BASE HREF="...">
  in HTML documents.
  
  =item 2.
  
  A "Content-Base:" or a "Content-Location:" header in the response.
  
  For backwards compatibility with older HTTP implementations we will
  also look for the "Base:" header.
  
  =item 3.
  
  The URI used to request this response. This might not be the original
  URI that was passed to $ua->request() method, because we might have
  received some redirect responses first.
  
  =back
  
  If none of these sources provide an absolute URI, undef is returned.
  
  When the LWP protocol modules produce the HTTP::Response object, then
  any base URI embedded in the document (step 1) will already have
  initialized the "Content-Base:" header. This means that this method
  only performs the last 2 steps (the content is not always available
  either).
  
  =item $r->filename
  
  Returns a filename for this response.  Note that doing sanity checks
  on the returned filename (eg. removing characters that cannot be used
  on the target filesystem where the filename would be used, and
  laundering it for security purposes) are the caller's responsibility;
  the only related thing done by this method is that it makes a simple
  attempt to return a plain filename with no preceding path segments.
  
  The filename is obtained from one the following sources (in priority
  order):
  
  =over 4
  
  =item 1.
  
  A "Content-Disposition:" header in the response.  Proper decoding of
  RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
  encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
  
  =item 2.
  
  A "Content-Location:" header in the response.
  
  =item 3.
  
  The URI used to request this response. This might not be the original
  URI that was passed to $ua->request() method, because we might have
  received some redirect responses first.
  
  =back
  
  If a filename cannot be derived from any of these sources, undef is
  returned.
  
  =item $r->as_string
  
  =item $r->as_string( $eol )
  
  Returns a textual representation of the response.
  
  =item $r->is_info
  
  =item $r->is_success
  
  =item $r->is_redirect
  
  =item $r->is_error
  
  These methods indicate if the response was informational, successful, a
  redirection, or an error.  See L<HTTP::Status> for the meaning of these.
  
  =item $r->error_as_HTML
  
  Returns a string containing a complete HTML document indicating what
  error occurred.  This method should only be called when $r->is_error
  is TRUE.
  
  =item $r->redirects
  
  Returns the list of redirect responses that lead up to this response
  by following the $r->previous chain.  The list order is oldest first.
  
  In scalar context return the number of redirect responses leading up
  to this one.
  
  =item $r->current_age
  
  Calculates the "current age" of the response as specified by RFC 2616
  section 13.2.3.  The age of a response is the time since it was sent
  by the origin server.  The returned value is a number representing the
  age in seconds.
  
  =item $r->freshness_lifetime( %opt )
  
  Calculates the "freshness lifetime" of the response as specified by
  RFC 2616 section 13.2.4.  The "freshness lifetime" is the length of
  time between the generation of a response and its expiration time.
  The returned value is the number of seconds until expiry.
  
  If the response does not contain an "Expires" or a "Cache-Control"
  header, then this function will apply some simple heuristic based on
  the "Last-Modified" header to determine a suitable lifetime.  The
  following options might be passed to control the heuristics:
  
  =over
  
  =item heuristic_expiry => $bool
  
  If passed as a FALSE value, don't apply heuristics and just return
  C<undef> when "Expires" or "Cache-Control" is lacking.
  
  =item h_lastmod_fraction => $num
  
  This number represent the fraction of the difference since the
  "Last-Modified" timestamp to make the expiry time.  The default is
  C<0.10>, the suggested typical setting of 10% in RFC 2616.
  
  =item h_min => $sec
  
  This is the lower limit of the heuristic expiry age to use.  The
  default is C<60> (1 minute).
  
  =item h_max => $sec
  
  This is the upper limit of the heuristic expiry age to use.  The
  default is C<86400> (24 hours).
  
  =item h_default => $sec
  
  This is the expiry age to use when nothing else applies.  The default
  is C<3600> (1 hour) or "h_min" if greater.
  
  =back
  
  =item $r->is_fresh( %opt )
  
  Returns TRUE if the response is fresh, based on the values of
  freshness_lifetime() and current_age().  If the response is no longer
  fresh, then it has to be re-fetched or re-validated by the origin
  server.
  
  Options might be passed to control expiry heuristics, see the
  description of freshness_lifetime().
  
  =item $r->fresh_until( %opt )
  
  Returns the time (seconds since epoch) when this entity is no longer fresh.
  
  Options might be passed to control expiry heuristics, see the
  description of freshness_lifetime().
  
  =back
  
  =head1 SEE ALSO
  
  L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
  
  =head1 COPYRIGHT
  
  Copyright 1995-2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
HTTP_RESPONSE

$fatpacked{"HTTP/Status.pm"} = <<'HTTP_STATUS';
  package HTTP::Status;
  
  use strict;
  require 5.002;   # because we use prototypes
  
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(is_info is_success is_redirect is_error status_message);
  @EXPORT_OK = qw(is_client_error is_server_error);
  $VERSION = "6.03";
  
  # Note also addition of mnemonics to @EXPORT below
  
  # Unmarked codes are from RFC 2616
  # See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes
  
  my %StatusCode = (
      100 => 'Continue',
      101 => 'Switching Protocols',
      102 => 'Processing',                      # RFC 2518 (WebDAV)
      200 => 'OK',
      201 => 'Created',
      202 => 'Accepted',
      203 => 'Non-Authoritative Information',
      204 => 'No Content',
      205 => 'Reset Content',
      206 => 'Partial Content',
      207 => 'Multi-Status',                    # RFC 2518 (WebDAV)
      208 => 'Already Reported',		      # RFC 5842
      300 => 'Multiple Choices',
      301 => 'Moved Permanently',
      302 => 'Found',
      303 => 'See Other',
      304 => 'Not Modified',
      305 => 'Use Proxy',
      307 => 'Temporary Redirect',
      400 => 'Bad Request',
      401 => 'Unauthorized',
      402 => 'Payment Required',
      403 => 'Forbidden',
      404 => 'Not Found',
      405 => 'Method Not Allowed',
      406 => 'Not Acceptable',
      407 => 'Proxy Authentication Required',
      408 => 'Request Timeout',
      409 => 'Conflict',
      410 => 'Gone',
      411 => 'Length Required',
      412 => 'Precondition Failed',
      413 => 'Request Entity Too Large',
      414 => 'Request-URI Too Large',
      415 => 'Unsupported Media Type',
      416 => 'Request Range Not Satisfiable',
      417 => 'Expectation Failed',
      418 => 'I\'m a teapot',		      # RFC 2324
      422 => 'Unprocessable Entity',            # RFC 2518 (WebDAV)
      423 => 'Locked',                          # RFC 2518 (WebDAV)
      424 => 'Failed Dependency',               # RFC 2518 (WebDAV)
      425 => 'No code',                         # WebDAV Advanced Collections
      426 => 'Upgrade Required',                # RFC 2817
      428 => 'Precondition Required',
      429 => 'Too Many Requests',
      431 => 'Request Header Fields Too Large',
      449 => 'Retry with',                      # unofficial Microsoft
      500 => 'Internal Server Error',
      501 => 'Not Implemented',
      502 => 'Bad Gateway',
      503 => 'Service Unavailable',
      504 => 'Gateway Timeout',
      505 => 'HTTP Version Not Supported',
      506 => 'Variant Also Negotiates',         # RFC 2295
      507 => 'Insufficient Storage',            # RFC 2518 (WebDAV)
      509 => 'Bandwidth Limit Exceeded',        # unofficial
      510 => 'Not Extended',                    # RFC 2774
      511 => 'Network Authentication Required',
  );
  
  my $mnemonicCode = '';
  my ($code, $message);
  while (($code, $message) = each %StatusCode) {
      # create mnemonic subroutines
      $message =~ s/I'm/I am/;
      $message =~ tr/a-z \-/A-Z__/;
      $mnemonicCode .= "sub HTTP_$message () { $code }\n";
      $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n";  # legacy
      $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
      $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
  }
  eval $mnemonicCode; # only one eval for speed
  die if $@;
  
  # backwards compatibility
  *RC_MOVED_TEMPORARILY = \&RC_FOUND;  # 302 was renamed in the standard
  push(@EXPORT, "RC_MOVED_TEMPORARILY");
  
  %EXPORT_TAGS = (
     constants => [grep /^HTTP_/, @EXPORT_OK],
     is => [grep /^is_/, @EXPORT, @EXPORT_OK],
  );
  
  
  sub status_message  ($) { $StatusCode{$_[0]}; }
  
  sub is_info         ($) { $_[0] >= 100 && $_[0] < 200; }
  sub is_success      ($) { $_[0] >= 200 && $_[0] < 300; }
  sub is_redirect     ($) { $_[0] >= 300 && $_[0] < 400; }
  sub is_error        ($) { $_[0] >= 400 && $_[0] < 600; }
  sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; }
  sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  HTTP::Status - HTTP Status code processing
  
  =head1 SYNOPSIS
  
   use HTTP::Status qw(:constants :is status_message);
  
   if ($rc != HTTP_OK) {
       print status_message($rc), "\n";
   }
  
   if (is_success($rc)) { ... }
   if (is_error($rc)) { ... }
   if (is_redirect($rc)) { ... }
  
  =head1 DESCRIPTION
  
  I<HTTP::Status> is a library of routines for defining and
  classifying HTTP status codes for libwww-perl.  Status codes are
  used to encode the overall outcome of an HTTP response message.  Codes
  correspond to those defined in RFC 2616 and RFC 2518.
  
  =head1 CONSTANTS
  
  The following constant functions can be used as mnemonic status code
  names.  None of these are exported by default.  Use the C<:constants>
  tag to import them all.
  
     HTTP_CONTINUE                        (100)
     HTTP_SWITCHING_PROTOCOLS             (101)
     HTTP_PROCESSING                      (102)
  
     HTTP_OK                              (200)
     HTTP_CREATED                         (201)
     HTTP_ACCEPTED                        (202)
     HTTP_NON_AUTHORITATIVE_INFORMATION   (203)
     HTTP_NO_CONTENT                      (204)
     HTTP_RESET_CONTENT                   (205)
     HTTP_PARTIAL_CONTENT                 (206)
     HTTP_MULTI_STATUS                    (207)
     HTTP_ALREADY_REPORTED		(208)
  
     HTTP_MULTIPLE_CHOICES                (300)
     HTTP_MOVED_PERMANENTLY               (301)
     HTTP_FOUND                           (302)
     HTTP_SEE_OTHER                       (303)
     HTTP_NOT_MODIFIED                    (304)
     HTTP_USE_PROXY                       (305)
     HTTP_TEMPORARY_REDIRECT              (307)
  
     HTTP_BAD_REQUEST                     (400)
     HTTP_UNAUTHORIZED                    (401)
     HTTP_PAYMENT_REQUIRED                (402)
     HTTP_FORBIDDEN                       (403)
     HTTP_NOT_FOUND                       (404)
     HTTP_METHOD_NOT_ALLOWED              (405)
     HTTP_NOT_ACCEPTABLE                  (406)
     HTTP_PROXY_AUTHENTICATION_REQUIRED   (407)
     HTTP_REQUEST_TIMEOUT                 (408)
     HTTP_CONFLICT                        (409)
     HTTP_GONE                            (410)
     HTTP_LENGTH_REQUIRED                 (411)
     HTTP_PRECONDITION_FAILED             (412)
     HTTP_REQUEST_ENTITY_TOO_LARGE        (413)
     HTTP_REQUEST_URI_TOO_LARGE           (414)
     HTTP_UNSUPPORTED_MEDIA_TYPE          (415)
     HTTP_REQUEST_RANGE_NOT_SATISFIABLE   (416)
     HTTP_EXPECTATION_FAILED              (417)
     HTTP_I_AM_A_TEAPOT			(418)
     HTTP_UNPROCESSABLE_ENTITY            (422)
     HTTP_LOCKED                          (423)
     HTTP_FAILED_DEPENDENCY               (424)
     HTTP_NO_CODE                         (425)
     HTTP_UPGRADE_REQUIRED                (426)
     HTTP_PRECONDITION_REQUIRED		(428)
     HTTP_TOO_MANY_REQUESTS		(429)
     HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431)
     HTTP_RETRY_WITH                      (449)
  
     HTTP_INTERNAL_SERVER_ERROR           (500)
     HTTP_NOT_IMPLEMENTED                 (501)
     HTTP_BAD_GATEWAY                     (502)
     HTTP_SERVICE_UNAVAILABLE             (503)
     HTTP_GATEWAY_TIMEOUT                 (504)
     HTTP_HTTP_VERSION_NOT_SUPPORTED      (505)
     HTTP_VARIANT_ALSO_NEGOTIATES         (506)
     HTTP_INSUFFICIENT_STORAGE            (507)
     HTTP_BANDWIDTH_LIMIT_EXCEEDED        (509)
     HTTP_NOT_EXTENDED                    (510)
     HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)
  
  =head1 FUNCTIONS
  
  The following additional functions are provided.  Most of them are
  exported by default.  The C<:is> import tag can be used to import all
  the classification functions.
  
  =over 4
  
  =item status_message( $code )
  
  The status_message() function will translate status codes to human
  readable strings. The string is the same as found in the constant
  names above.  If the $code is unknown, then C<undef> is returned.
  
  =item is_info( $code )
  
  Return TRUE if C<$code> is an I<Informational> status code (1xx).  This
  class of status code indicates a provisional response which can't have
  any content.
  
  =item is_success( $code )
  
  Return TRUE if C<$code> is a I<Successful> status code (2xx).
  
  =item is_redirect( $code )
  
  Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
  status code indicates that further action needs to be taken by the
  user agent in order to fulfill the request.
  
  =item is_error( $code )
  
  Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx).  The function
  returns TRUE for both client and server error status codes.
  
  =item is_client_error( $code )
  
  Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
  of status code is intended for cases in which the client seems to have
  erred.
  
  This function is B<not> exported by default.
  
  =item is_server_error( $code )
  
  Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
  of status codes is intended for cases in which the server is aware
  that it has erred or is incapable of performing the request.
  
  This function is B<not> exported by default.
  
  =back
  
  =head1 BUGS
  
  For legacy reasons all the C<HTTP_> constants are exported by default
  with the prefix C<RC_>.  It's recommended to use explicit imports and
  the C<:constants> tag instead of relying on this.
HTTP_STATUS

$fatpacked{"IO/All.pm"} = <<'IO_ALL';
  package IO::All;
  use 5.006001;
  use strict;
  use warnings;
  
  require Carp;
  # So one can use Carp::carp "$message" - without the parenthesis.
  sub Carp::carp;
  
  use IO::All::Base -base;
  
  use File::Spec();
  use Symbol();
  use Fcntl;
  
  our $VERSION = '0.46';
  our @EXPORT = qw(io);
  
  #===============================================================================
  # Object creation and setup methods
  #===============================================================================
  my $autoload = {
      qw(
          touch file
  
          dir_handle dir
          All dir
          all_files dir
          All_Files dir
          all_dirs dir
          All_Dirs dir
          all_links dir
          All_Links dir
          mkdir dir
          mkpath dir
          next dir
  
          stdin stdio
          stdout stdio
          stderr stdio
  
          socket_handle socket
          accept socket
          shutdown socket
  
          readlink link
          symlink link
      )
  };
  
  # XXX - These should die if the given argument exists but is not a
  # link, dbm, etc.
  sub link {my $self = shift; require IO::All::Link; IO::All::Link::link($self, @_) }
  sub dbm {my $self = shift; require IO::All::DBM; IO::All::DBM::dbm($self, @_) }
  sub mldbm {my $self = shift; require IO::All::MLDBM; IO::All::MLDBM::mldbm($self, @_) }
  
  sub autoload {my $self = shift; $autoload }
  
  sub AUTOLOAD {
      my $self = shift;
      my $method = $IO::All::AUTOLOAD;
      $method =~ s/.*:://;
      my $pkg = ref($self) || $self;
      $self->throw(qq{Can't locate object method "$method" via package "$pkg"})
        if $pkg ne $self->package;
      my $class = $self->autoload_class($method);
      my $foo = "$self";
      bless $self, $class;
      $self->$method(@_);
  }
  
  sub autoload_class {
      my $self = shift;
      my $method = shift;
      my $class_id = $self->autoload->{$method} || $method;
      my $ucfirst_class_name = 'IO::All::' . ucfirst($class_id);
      my $ucfirst_class_fn = "IO/All/" . ucfirst($class_id) . ".pm";
      return $ucfirst_class_name if $INC{$ucfirst_class_fn};
      return "IO::All::\U$class_id" if $INC{"IO/All/\U$class_id\E.pm"};
      require IO::All::Temp;
      if (eval "require $ucfirst_class_name; 1") {
          my $class = $ucfirst_class_name;
          my $return = $class->can('new')
          ? $class
          : do { # (OS X hack)
              my $value = $INC{$ucfirst_class_fn};
              delete $INC{$ucfirst_class_fn};
              $INC{"IO/All/\U$class_id\E.pm"} = $value;
              "IO::All::\U$class_id";
          };
          return $return;
      }
      elsif (eval "require IO::All::\U$class_id; 1") {
          return "IO::All::\U$class_id";
      }
      $self->throw("Can't find a class for method '$method'");
  }
  
  sub new {
      my $self = shift;
      my $package = ref($self) || $self;
      my $new = bless Symbol::gensym(), $package;
      $new->package($package);
      $new->_copy_from($self) if ref($self);
      my $name = shift;
      return $name if UNIVERSAL::isa($name, 'IO::All');
      return $new->_init unless defined $name;
      return $new->handle($name)
        if UNIVERSAL::isa($name, 'GLOB') or ref(\ $name) eq 'GLOB';
      # WWW - link is first because a link to a dir returns true for
      # both -l and -d.
      return $new->link($name) if -l $name;
      return $new->file($name) if -f $name;
      return $new->dir($name) if -d $name;
      return $new->$1($name) if $name =~ /^([a-z]{3,8}):/;
      return $new->socket($name) if $name =~ /^[\w\-\.]*:\d{1,5}$/;
      return $new->pipe($name)
        if $name =~ s/^\s*\|\s*// or $name =~ s/\s*\|\s*$//;
      return $new->string if $name eq '$';
      return $new->stdio if $name eq '-';
      return $new->stderr if $name eq '=';
      return $new->temp if $name eq '?';
      $new->name($name);
      $new->_init;
  }
  
  sub _copy_from {
      my $self = shift;
      my $other = shift;
      for (keys(%{*$other})) {
          # XXX Need to audit exclusions here
          next if /^(_handle|io_handle|is_open)$/;
          *$self->{$_} = *$other->{$_};
      }
  }
  
  sub handle {
      my $self = shift;
      $self->_handle(shift) if @_;
      return $self->_init;
  }
  
  #===============================================================================
  # Tie Interface
  #===============================================================================
  sub tie {
      my $self = shift;
      tie *$self, $self;
      return $self;
  }
  
  sub TIEHANDLE {
      return $_[0] if ref $_[0];
      my $class = shift;
      my $self = bless Symbol::gensym(), $class;
      $self->init(@_);
  }
  
  sub READLINE {
      goto &getlines if wantarray;
      goto &getline;
  }
  
  sub DESTROY {
      my $self = shift;
      no warnings;
      unless ( $] < 5.008 ) {
          untie *$self if tied *$self;
      }
      $self->close if $self->is_open;
  }
  
  sub BINMODE {
      my $self = shift;
      binmode *$self->io_handle;
  }
  
  {
      no warnings;
      *GETC   = \&getc;
      *PRINT  = \&print;
      *PRINTF = \&printf;
      *READ   = \&read;
      *WRITE  = \&write;
      *SEEK   = \&seek;
      *TELL   = \&getpos;
      *EOF    = \&eof;
      *CLOSE  = \&close;
      *FILENO = \&fileno;
  }
  
  #===============================================================================
  # Overloading support
  #===============================================================================
  my $old_warn_handler = $SIG{__WARN__};
  $SIG{__WARN__} = sub {
      if ($_[0] !~ /^Useless use of .+ \(.+\) in void context/) {
          goto &$old_warn_handler if $old_warn_handler;
          warn(@_);
      }
  };
  
  use overload '""' => 'overload_stringify';
  use overload '|' => 'overload_bitwise_or';
  use overload '<<' => 'overload_left_bitshift';
  use overload '>>' => 'overload_right_bitshift';
  use overload '<' => 'overload_less_than';
  use overload '>' => 'overload_greater_than';
  use overload '${}' => 'overload_string_deref';
  use overload '@{}' => 'overload_array_deref';
  use overload '%{}' => 'overload_hash_deref';
  use overload '&{}' => 'overload_code_deref';
  
  sub overload_bitwise_or {my $self = shift; $self->overload_handler(@_, '|') }
  sub overload_left_bitshift {my $self = shift; $self->overload_handler(@_, '<<') }
  sub overload_right_bitshift {my $self = shift; $self->overload_handler(@_, '>>') }
  sub overload_less_than {my $self = shift; $self->overload_handler(@_, '<') }
  sub overload_greater_than {my $self = shift; $self->overload_handler(@_, '>') }
  sub overload_string_deref {my $self = shift; $self->overload_handler(@_, '${}') }
  sub overload_array_deref {my $self = shift; $self->overload_handler(@_, '@{}') }
  sub overload_hash_deref {my $self = shift; $self->overload_handler(@_, '%{}') }
  sub overload_code_deref {my $self = shift; $self->overload_handler(@_, '&{}') }
  
  sub overload_handler {
      my ($self) = @_;
      my $method = $self->get_overload_method(@_);
      $self->$method(@_);
  }
  
  my $op_swap = {
      '>' => '<', '>>' => '<<',
      '<' => '>', '<<' => '>>',
  };
  
  sub overload_table {
      my $self = shift;
      (
          '* > *' => 'overload_any_to_any',
          '* < *' => 'overload_any_from_any',
          '* >> *' => 'overload_any_addto_any',
          '* << *' => 'overload_any_addfrom_any',
  
          '* < scalar' => 'overload_scalar_to_any',
          '* > scalar' => 'overload_any_to_scalar',
          '* << scalar' => 'overload_scalar_addto_any',
          '* >> scalar' => 'overload_any_addto_scalar',
      )
  };
  
  sub get_overload_method {
      my ($self, $arg1, $arg2, $swap, $operator) = @_;
      if ($swap) {
          $operator = $op_swap->{$operator} || $operator;
      }
      my $arg1_type = $self->get_argument_type($arg1);
      my $table1 = { $arg1->overload_table };
  
      if ($operator =~ /\{\}$/) {
          my $key = "$operator $arg1_type";
          return $table1->{$key} || $self->overload_undefined($key);
      }
  
      my $arg2_type = $self->get_argument_type($arg2);
      my @table2 = UNIVERSAL::isa($arg2, "IO::All")
      ? ($arg2->overload_table)
      : ();
      my $table = { %$table1, @table2 };
  
      my @keys = (
          "$arg1_type $operator $arg2_type",
          "* $operator $arg2_type",
      );
      push @keys, "$arg1_type $operator *", "* $operator *"
        unless $arg2_type =~ /^(scalar|array|hash|code|ref)$/;
  
      for (@keys) {
          return $table->{$_}
            if defined $table->{$_};
      }
  
      return $self->overload_undefined($keys[0]);
  }
  
  sub get_argument_type {
      my $self = shift;
      my $argument = shift;
      my $ref = ref($argument);
      return 'scalar' unless $ref;
      return 'code' if $ref eq 'CODE';
      return 'array' if $ref eq 'ARRAY';
      return 'hash' if $ref eq 'HASH';
      return 'ref' unless $argument->isa('IO::All');
      $argument->file
        if defined $argument->pathname and not $argument->type;
      return $argument->type || 'unknown';
  }
  
  sub overload_stringify {
      my $self = shift;
      my $name = $self->pathname;
      return defined($name) ? $name : overload::StrVal($self);
  }
  
  sub overload_undefined {
      my $self = shift;
      require Carp;
      my $key = shift;
      Carp::carp "Undefined behavior for overloaded IO::All operation: '$key'"
        if $^W;
      return 'overload_noop';
  }
  
  sub overload_noop {
      my $self = shift;
      return;
  }
  
  sub overload_any_addfrom_any {
      $_[1]->append($_[2]->all);
      $_[1];
  }
  
  sub overload_any_addto_any {
      $_[2]->append($_[1]->all);
      $_[2];
  }
  
  sub overload_any_from_any {
      $_[1]->close if $_[1]->is_file and $_[1]->is_open;
      $_[1]->print($_[2]->all);
      $_[1];
  }
  
  sub overload_any_to_any {
      $_[2]->close if $_[2]->is_file and $_[2]->is_open;
      $_[2]->print($_[1]->all);
      $_[2];
  }
  
  sub overload_any_to_scalar {
      $_[2] = $_[1]->all;
  }
  
  sub overload_any_addto_scalar {
      $_[2] .= $_[1]->all;
      $_[2];
  }
  
  sub overload_scalar_addto_any {
      $_[1]->append($_[2]);
      $_[1];
  }
  
  sub overload_scalar_to_any {
      local $\;
      $_[1]->close if $_[1]->is_file and $_[1]->is_open;
      $_[1]->print($_[2]);
      $_[1];
  }
  
  #===============================================================================
  # Private Accessors
  #===============================================================================
  field 'package';
  field _binary => undef;
  field _binmode => undef;
  field _strict => undef;
  field _encoding => undef;
  field _utf8 => undef;
  field _handle => undef;
  
  #===============================================================================
  # Public Accessors
  #===============================================================================
  field constructor => undef;
  chain block_size => 1024;
  chain errors => undef;
  field io_handle => undef;
  field is_open => 0;
  chain mode => undef;
  chain name => undef;
  chain perms => undef;
  chain separator => $/;
  field type => '';
  sub pathname {my $self = shift; $self->name(@_) }
  
  #===============================================================================
  # Chainable option methods (write only)
  #===============================================================================
  option 'assert';
  option 'autoclose' => 1;
  option 'backwards';
  option 'chomp';
  option 'confess';
  option 'lock';
  option 'rdonly';
  option 'rdwr';
  option 'strict';
  
  #===============================================================================
  # IO::Handle proxy methods
  #===============================================================================
  proxy 'autoflush';
  proxy 'eof';
  proxy 'fileno';
  proxy 'stat';
  proxy 'tell';
  proxy 'truncate';
  
  #===============================================================================
  # IO::Handle proxy methods that open the handle if needed
  #===============================================================================
  proxy_open print => '>';
  proxy_open printf => '>';
  proxy_open sysread => O_RDONLY;
  proxy_open syswrite => O_CREAT | O_WRONLY;
  proxy_open seek => $^O eq 'MSWin32' ? '<' : '+<';
  proxy_open 'getc';
  
  #===============================================================================
  # File::Spec Interface
  #===============================================================================
  sub canonpath {my $self = shift; File::Spec->canonpath($self->pathname) }
  sub catdir {
      my $self = shift;
      my @args = grep defined, $self->name, @_;
      $self->constructor->()->dir(File::Spec->catdir(@args));
  }
  sub catfile {
      my $self = shift;
      my @args = grep defined, $self->name, @_;
      $self->constructor->()->file(File::Spec->catfile(@args));
  }
  sub join {my $self = shift; $self->catfile(@_) }
  sub curdir {
      my $self = shift;
      $self->constructor->()->dir(File::Spec->curdir);
  }
  sub devnull {
      my $self = shift;
      $self->constructor->()->file(File::Spec->devnull);
  }
  sub rootdir {
      my $self = shift;
      $self->constructor->()->dir(File::Spec->rootdir);
  }
  sub tmpdir {
      my $self = shift;
      $self->constructor->()->dir(File::Spec->tmpdir);
  }
  sub updir {
      my $self = shift;
      $self->constructor->()->dir(File::Spec->updir);
  }
  sub case_tolerant {
      my $self = shift;
      File::Spec->case_tolerant;
  }
  sub is_absolute {
      my $self = shift;
      File::Spec->file_name_is_absolute($self->pathname);
  }
  sub path {
      my $self = shift;
      map { $self->constructor->()->dir($_) } File::Spec->path;
  }
  sub splitpath {
      my $self = shift;
      File::Spec->splitpath($self->pathname);
  }
  sub splitdir {
      my $self = shift;
      File::Spec->splitdir($self->pathname);
  }
  sub catpath {
      my $self = shift;
      $self->constructor->(File::Spec->catpath(@_));
  }
  sub abs2rel {
      my $self = shift;
      File::Spec->abs2rel($self->pathname, @_);
  }
  sub rel2abs {
      my $self = shift;
      File::Spec->rel2abs($self->pathname, @_);
  }
  
  #===============================================================================
  # Public IO Action Methods
  #===============================================================================
  sub absolute {
      my $self = shift;
      $self->pathname(File::Spec->rel2abs($self->pathname))
        unless $self->is_absolute;
      $self->is_absolute(1);
      return $self;
  }
  
  sub all {
      my $self = shift;
      $self->assert_open('<');
      local $/;
      my $all = $self->io_handle->getline;
      $self->error_check;
      $self->_autoclose && $self->close;
      return $all;
  }
  
  sub append {
      my $self = shift;
      $self->assert_open('>>');
      $self->print(@_);
  }
  
  sub appendln {
      my $self = shift;
      $self->assert_open('>>');
      $self->println(@_);
  }
  
  sub binary {
      my $self = shift;
      binmode($self->io_handle)
        if $self->is_open;
      $self->_binary(1);
      return $self;
  }
  
  sub binmode {
      my $self = shift;
      my $layer = shift;
      if ($self->is_open) {
          $layer
          ? CORE::binmode($self->io_handle, $layer)
          : CORE::binmode($self->io_handle);
      }
      $self->_binmode($layer);
      return $self;
  }
  
  sub buffer {
      my $self = shift;
      if (not @_) {
          *$self->{buffer} = do {my $x = ''; \ $x}
            unless exists *$self->{buffer};
          return *$self->{buffer};
      }
      my $buffer_ref = ref($_[0]) ? $_[0] : \ $_[0];
      $$buffer_ref = '' unless defined $$buffer_ref;
      *$self->{buffer} = $buffer_ref;
      return $self;
  }
  
  sub clear {
      my $self = shift;
      my $buffer = *$self->{buffer};
      $$buffer = '';
      return $self;
  }
  
  sub close {
      my $self = shift;
      return unless $self->is_open;
      $self->is_open(0);
      my $io_handle = $self->io_handle;
      $self->io_handle(undef);
      $self->mode(undef);
      $io_handle->close(@_)
        if defined $io_handle;
      return $self;
  }
  
  sub empty {
      my $self = shift;
      my $message =
        "Can't call empty on an object that is neither file nor directory";
      $self->throw($message);
  }
  
  sub exists {my $self = shift; -e $self->pathname }
  
  sub getline {
      my $self = shift;
      return $self->getline_backwards
        if $self->_backwards;
      $self->assert_open('<');
      my $line;
      {
          local $/ = @_ ? shift(@_) : $self->separator;
          $line = $self->io_handle->getline;
          chomp($line) if $self->_chomp and defined $line;
      }
      $self->error_check;
      return $line if defined $line;
      $self->close if $self->_autoclose;
      return undef;
  }
  
  sub getlines {
      my $self = shift;
      return $self->getlines_backwards
        if $self->_backwards;
      $self->assert_open('<');
      my @lines;
      {
          local $/ = @_ ? shift(@_) : $self->separator;
          @lines = $self->io_handle->getlines;
          if ($self->_chomp) {
              chomp for @lines;
          }
      }
      $self->error_check;
      return (@lines) or
             $self->_autoclose && $self->close && () or
             ();
  }
  
  sub is_dir {my $self = shift; UNIVERSAL::isa($self, 'IO::All::Dir') }
  sub is_dbm {my $self = shift; UNIVERSAL::isa($self, 'IO::All::DBM') }
  sub is_file {my $self = shift; UNIVERSAL::isa($self, 'IO::All::File') }
  sub is_link {my $self = shift; UNIVERSAL::isa($self, 'IO::All::Link') }
  sub is_mldbm {my $self = shift; UNIVERSAL::isa($self, 'IO::All::MLDBM') }
  sub is_socket {my $self = shift; UNIVERSAL::isa($self, 'IO::All::Socket') }
  sub is_stdio {my $self = shift; UNIVERSAL::isa($self, 'IO::All::STDIO') }
  sub is_string {my $self = shift; UNIVERSAL::isa($self, 'IO::All::String') }
  sub is_temp {my $self = shift; UNIVERSAL::isa($self, 'IO::All::Temp') }
  
  sub length {
      my $self = shift;
      length(${$self->buffer});
  }
  
  sub open {
      my $self = shift;
      return $self if $self->is_open;
      $self->is_open(1);
      my ($mode, $perms) = @_;
      $self->mode($mode) if defined $mode;
      $self->mode('<') unless defined $self->mode;
      $self->perms($perms) if defined $perms;
      my @args;
      unless ($self->is_dir) {
          push @args, $self->mode;
          push @args, $self->perms if defined $self->perms;
      }
      if (defined $self->pathname and not $self->type) {
          $self->file;
          return $self->open(@args);
      }
      elsif (defined $self->_handle and
             not $self->io_handle->opened
            ) {
          # XXX Not tested
          $self->io_handle->fdopen($self->_handle, @args);
      }
      $self->set_binmode;
  }
  
  sub println {
      my $self = shift;
      $self->print(map {/\n\z/ ? ($_) : ($_, "\n")} @_);
  }
  
  sub read {
      my $self = shift;
      $self->assert_open('<');
      my $length = (@_ or $self->type eq 'dir')
      ? $self->io_handle->read(@_)
      : $self->io_handle->read(
          ${$self->buffer},
          $self->block_size,
          $self->length,
      );
      $self->error_check;
      return $length || $self->_autoclose && $self->close && 0;
  }
  
  {
      no warnings;
      *readline = \&getline;
  }
  
  # deprecated
  sub scalar {
      my $self = shift;
      $self->all(@_);
  }
  
  sub slurp {
      my $self = shift;
      my $slurp = $self->all;
      return $slurp unless wantarray;
      my $separator = $self->separator;
      if ($self->_chomp) {
          local $/ = $separator;
          map {chomp; $_} split /(?<=\Q$separator\E)/, $slurp;
      }
      else {
          split /(?<=\Q$separator\E)/, $slurp;
      }
  }
  
  sub utf8 {
      my $self = shift;
      if ($] < 5.008) {
          die "IO::All -utf8 not supported on Perl older than 5.8";
      }
      CORE::binmode($self->io_handle, ':utf8')
        if $self->is_open;
      $self->_utf8(1);
      $self->encoding('utf8');
      return $self;
  }
  
  sub encoding {
      my $self = shift;
      my $encoding = shift
        or die "No encoding value passed to IO::All::encoding";
      if ($] < 5.008) {
          die "IO::All -encoding not supported on Perl older than 5.8";
      }
      CORE::binmode($self->io_handle, ":$encoding")
        if $self->is_open;
      $self->_encoding($encoding);
      return $self;
  }
  
  sub write {
      my $self = shift;
      $self->assert_open('>');
      my $length = @_
      ? $self->io_handle->write(@_)
      : $self->io_handle->write(${$self->buffer}, $self->length);
      $self->error_check;
      $self->clear unless @_;
      return $length;
  }
  
  #===============================================================================
  # Implementation methods. Subclassable.
  #===============================================================================
  sub throw {
      my $self = shift;
      require Carp;
      ;
      return &{$self->errors}(@_)
        if $self->errors;
      return Carp::confess(@_)
        if $self->_confess;
      return Carp::croak(@_);
  }
  
  #===============================================================================
  # Private instance methods
  #===============================================================================
  sub assert_dirpath {
      my $self = shift;
      my $dir_name = shift;
      return $dir_name if -d $dir_name or
        CORE::mkdir($self->pathname, $self->perms || 0755) or
        do {
            require File::Path;
            File::Path::mkpath($dir_name);
        } or
        $self->throw("Can't make $dir_name");
  }
  
  sub assert_open {
      my $self = shift;
      return if $self->is_open;
      $self->file unless $self->type;
      return $self->open(@_);
  }
  
  sub error_check {
      my $self = shift;
      return unless $self->io_handle->can('error');
      return unless $self->io_handle->error;
      $self->throw($!);
  }
  
  sub copy {
      my $self = shift;
      my $copy;
      for (keys %{*$self}) {
          $copy->{$_} = *$self->{$_};
      }
      $copy->{io_handle} = 'defined'
        if defined $copy->{io_handle};
      return $copy;
  }
  
  sub set_binmode {
      my $self = shift;
      if (my $encoding = $self->_encoding) {
          CORE::binmode($self->io_handle, ":encoding($encoding)");
      }
      elsif ($self->_binary) {
          CORE::binmode($self->io_handle);
      }
      elsif ($self->_binmode) {
          CORE::binmode($self->io_handle, $self->_binmode);
      }
      return $self;
  }
  
  #===============================================================================
  # Stat Methods
  #===============================================================================
  BEGIN {
      no strict 'refs';
      my @stat_fields = qw(
          device inode modes nlink uid gid device_id size atime mtime
          ctime blksize blocks
      );
      foreach my $stat_field_idx (0 .. $#stat_fields)
      {
          my $idx = $stat_field_idx;
          my $name = $stat_fields[$idx];
  
          *$name = sub {
              my $self = shift;
              return (stat($self->io_handle || $self->pathname))[$idx];
          };
      }
  }
  
IO_ALL

$fatpacked{"IO/All/Base.pm"} = <<'IO_ALL_BASE';
  package IO::All::Base;
  use strict;
  use warnings;
  use Fcntl;
  
  sub import {
      my $class = shift;
      my $flag = $_[0] || '';
      my $package = caller;
      no strict 'refs';
      if ($flag eq '-base') {
          push @{$package . "::ISA"}, $class;
          *{$package . "::$_"} = \&$_
            for qw'field const option chain proxy proxy_open';
      }
      elsif ($flag eq -mixin) {
          mixin_import(scalar(caller(0)), $class, @_);
      }
      else {
          my @flags = @_;
          for my $export (@{$class . '::EXPORT'}) {
              *{$package . "::$export"} = $export eq 'io'
              ? $class->generate_constructor(@flags)
              : \&{$class . "::$export"};
          }
      }
  }
  
  sub generate_constructor {
      my $class = shift;
      my (@flags, %flags, $key);
      for (@_) {
          if (s/^-//) {
              push @flags, $_;
              $flags{$_} = 1;
              $key = $_;
          }
          else {
              $flags{$key} = $_ if $key;
          }
      }
      my $constructor;
      $constructor = sub {
          my $self = $class->new(@_);
          for (@flags) {
              $self->$_($flags{$_});
          }
          $self->constructor($constructor);
          return $self;
      }
  }
  
  sub _init {
      my $self = shift;
      $self->io_handle(undef);
      $self->is_open(0);
      return $self;
  }
  
  #===============================================================================
  # Closure generating functions
  #===============================================================================
  sub option {
      my $package = caller;
      my ($field, $default) = @_;
      $default ||= 0;
      field("_$field", $default);
      no strict 'refs';
      *{"${package}::$field"} =
        sub {
            my $self = shift;
            *$self->{"_$field"} = @_ ? shift(@_) : 1;
            return $self;
        };
  }
  
  sub chain {
      my $package = caller;
      my ($field, $default) = @_;
      no strict 'refs';
      *{"${package}::$field"} =
        sub {
            my $self = shift;
            if (@_) {
                *$self->{$field} = shift;
                return $self;
            }
            return $default unless exists *$self->{$field};
            return *$self->{$field};
        };
  }
  
  sub field {
      my $package = caller;
      my ($field, $default) = @_;
      no strict 'refs';
      return if defined &{"${package}::$field"};
      *{"${package}::$field"} =
        sub {
            my $self = shift;
            unless (exists *$self->{$field}) {
                *$self->{$field} =
                  ref($default) eq 'ARRAY' ? [] :
                  ref($default) eq 'HASH' ? {} :
                  $default;
            }
            return *$self->{$field} unless @_;
            *$self->{$field} = shift;
        };
  }
  
  sub const {
      my $package = caller;
      my ($field, $default) = @_;
      no strict 'refs';
      return if defined &{"${package}::$field"};
      *{"${package}::$field"} = sub { $default };
  }
  
  sub proxy {
      my $package = caller;
      my ($proxy) = @_;
      no strict 'refs';
      return if defined &{"${package}::$proxy"};
      *{"${package}::$proxy"} =
        sub {
            my $self = shift;
            my @return = $self->io_handle->$proxy(@_);
            $self->error_check;
            wantarray ? @return : $return[0];
        };
  }
  
  sub proxy_open {
      my $package = caller;
      my ($proxy, @args) = @_;
      no strict 'refs';
      return if defined &{"${package}::$proxy"};
      my $method = sub {
          my $self = shift;
          $self->assert_open(@args);
          my @return = $self->io_handle->$proxy(@_);
          $self->error_check;
          wantarray ? @return : $return[0];
      };
      *{"$package\::$proxy"} =
      (@args and $args[0] eq '>') ?
      sub {
          my $self = shift;
          $self->$method(@_);
          return $self;
      }
      : $method;
  }
  
  sub mixin_import {
      my $target_class = shift;
      $target_class = caller(0)
        if $target_class eq 'mixin';
      my $mixin_class = shift
        or die "Nothing to mixin";
      eval "require $mixin_class";
      my $pseudo_class = CORE::join '-', $target_class, $mixin_class;
      my %methods = mixin_methods($mixin_class);
      no strict 'refs';
      no warnings;
      @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
      @{"$target_class\::ISA"} = ($pseudo_class);
      for (keys %methods) {
          *{"$pseudo_class\::$_"} = $methods{$_};
      }
  }
  
  sub mixin_methods {
      my $mixin_class = shift;
      no strict 'refs';
      my %methods = all_methods($mixin_class);
      map {
          $methods{$_}
            ? ($_, \ &{"$methods{$_}\::$_"})
            : ($_, \ &{"$mixin_class\::$_"})
      } (keys %methods);
  }
  
  sub all_methods {
      no strict 'refs';
      my $class = shift;
      my %methods = map {
          ($_, $class)
      } grep {
          defined &{"$class\::$_"} and not /^_/
      } keys %{"$class\::"};
      return (%methods);
  }
  
  1;
IO_ALL_BASE

$fatpacked{"IO/All/DBM.pm"} = <<'IO_ALL_DBM';
  package IO::All::DBM;
  use strict;
  use warnings;
  use IO::All::File -base;
  use Fcntl;
  
  field _dbm_list => [];
  field '_dbm_class';
  field _dbm_extra => [];
  
  sub dbm {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->_dbm_list([@_]);
      return $self;
  }
  
  sub assert_open {
      my $self = shift;
      return $self->tied_file
        if $self->tied_file;
      $self->open;
  }
  
  sub assert_filepath {
      my $self = shift;
      $self->SUPER::assert_filepath(@_);
      if ($self->_rdonly and not -e $self->pathname) {
          my $rdwr = $self->_rdwr;
          $self->assert(0)->rdwr(1)->rdonly(0)->open;
          $self->close;
          $self->assert(1)->rdwr($rdwr)->rdonly(1);
      }
  }
  
  sub open {
      my $self = shift;
      $self->is_open(1);
      return $self->tied_file if $self->tied_file;
      $self->assert_filepath if $self->_assert;
      my $dbm_list = $self->_dbm_list;
      my @dbm_list = @$dbm_list ? @$dbm_list :
        (qw(DB_File GDBM_File NDBM_File ODBM_File SDBM_File));
      my $dbm_class;
      for my $module (@dbm_list) {
          (my $file = "$module.pm") =~ s{::}{/}g;
          if (defined $INC{$file} || eval "eval 'use $module; 1'") {
              $self->_dbm_class($module);
              last;
          }
      }
      $self->throw("No module available for IO::All DBM operation")
        unless defined $self->_dbm_class;
      my $mode = $self->_rdonly ? O_RDONLY : O_RDWR;
      if ($self->_dbm_class eq 'DB_File::Lock') {
          $self->_dbm_class->import;
          my $type = eval '$DB_HASH'; die $@ if $@;
          # XXX Not sure about this warning
          warn "Using DB_File::Lock in IO::All without the rdonly or rdwr method\n"
            if not ($self->_rdwr or $self->_rdonly);
          my $flag = $self->_rdwr ? 'write' : 'read';
          $mode = $self->_rdwr ? O_RDWR : O_RDONLY;
          $self->_dbm_extra([$type, $flag]);
      }
      $mode |= O_CREAT if $mode & O_RDWR;
      $self->mode($mode);
      $self->perms(0666) unless defined $self->perms;
      return $self->tie_dbm;
  }
  
  sub tie_dbm {
      my $self = shift;
      my $hash;
      my $filename = $self->name;
      my $db = tie %$hash, $self->_dbm_class, $filename, $self->mode, $self->perms,
          @{$self->_dbm_extra}
        or $self->throw("Can't open '$filename' as DBM file:\n$!");
      $self->add_utf8_dbm_filter($db)
        if $self->_utf8;
      $self->tied_file($hash);
  }
  
  sub add_utf8_dbm_filter {
      my $self = shift;
      my $db = shift;
      $db->filter_store_key(sub { utf8::encode($_) });
      $db->filter_store_value(sub { utf8::encode($_) });
      $db->filter_fetch_key(sub { utf8::decode($_) });
      $db->filter_fetch_value(sub { utf8::decode($_) });
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::DBM - DBM Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_DBM

$fatpacked{"IO/All/Dir.pm"} = <<'IO_ALL_DIR';
  package IO::All::Dir;
  use strict;
  use warnings;
  use IO::All::Filesys -base;
  use IO::All -base;
  use IO::Dir;
  
  #===============================================================================
  const type => 'dir';
  option 'sort' => 1;
  chain filter => undef;
  option 'deep';
  field 'chdir_from';
  
  #===============================================================================
  sub dir {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->name(shift) if @_;
      return $self->_init;
  }
  
  sub dir_handle {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->_handle(shift) if @_;
      return $self->_init;
  }
  
  #===============================================================================
  sub assert_open {
      my $self = shift;
      return if $self->is_open;
      $self->open;
  }
  
  sub open {
      my $self = shift;
      $self->is_open(1);
      $self->assert_dirpath($self->pathname)
        if $self->pathname and $self->_assert;
      my $handle = IO::Dir->new;
      $self->io_handle($handle);
      $handle->open($self->pathname)
        or $self->throw($self->open_msg);
      return $self;
  }
  
  sub open_msg {
      my $self = shift;
      my $name = defined $self->pathname
        ? " '" . $self->pathname . "'"
        : '';
      return qq{Can't open directory$name:\n$!};
  }
  
  #===============================================================================
  sub All {
      my $self = shift;
      $self->all(0);
  }
  
  sub all {
      my $self = shift;
      my $depth = @_ ? shift(@_) : $self->_deep ? 0 : 1;
      my $first = not @_;
      my @all;
      while (my $io = $self->next) {
          push @all, $io;
          push(@all, $io->all($depth - 1, 1))
            if $depth != 1 and $io->is_dir;
      }
      @all = grep {&{$self->filter}} @all
        if $self->filter;
      return @all unless $first and $self->_sort;
      return sort {$a->pathname cmp $b->pathname} @all;
  }
  
  sub All_Dirs {
      my $self = shift;
      $self->all_dirs(0);
  }
  
  sub all_dirs {
      my $self = shift;
      grep {$_->is_dir} $self->all(@_);
  }
  
  sub All_Files {
      my $self = shift;
      $self->all_files(0);
  }
  
  sub all_files {
      my $self = shift;
      grep {$_->is_file} $self->all(@_);
  }
  
  sub All_Links {
      my $self = shift;
      $self->all_links(0);
  }
  
  sub all_links {
      my $self = shift;
      grep {$_->is_link} $self->all(@_);
  }
  
  sub chdir {
      my $self = shift;
      require Cwd;
      $self->chdir_from(Cwd::cwd());
      CORE::chdir($self->pathname);
      return $self;
  }
  
  sub empty {
      my $self = shift;
      my $dh;
      opendir($dh, $self->pathname) or die;
      while (my $dir = readdir($dh)) {
         return 0 unless $dir =~ /^\.{1,2}$/;
      }
      return 1;
  }
  
  sub mkdir {
      my $self = shift;
      defined($self->perms)
      ? CORE::mkdir($self->pathname, $self->perms)
      : CORE::mkdir($self->pathname);
      return $self;
  }
  
  sub mkpath {
      my $self = shift;
      require File::Path;
      File::Path::mkpath($self->pathname, @_);
      return $self;
  }
  
  sub next {
      my $self = shift;
      $self->assert_open;
      my $name = $self->readdir;
      return unless defined $name;
      my $io = $self->constructor->(File::Spec->catfile($self->pathname, $name));
      $io->absolute if $self->is_absolute;
      return $io;
  }
  
  sub readdir {
      my $self = shift;
      $self->assert_open;
      if (wantarray) {
          my @return = grep {
              not /^\.{1,2}$/
          } $self->io_handle->read;
          $self->close;
          return @return;
      }
      my $name = '.';
      while ($name =~ /^\.{1,2}$/) {
          $name = $self->io_handle->read;
          unless (defined $name) {
              $self->close;
              return;
          }
      }
      return $name;
  }
  
  sub rmdir {
      my $self = shift;
      rmdir $self->pathname;
  }
  
  sub rmtree {
      my $self = shift;
      require File::Path;
      File::Path::rmtree($self->pathname, @_);
  }
  
  sub DESTROY {
      my $self = shift;
      CORE::chdir($self->chdir_from)
        if $self->chdir_from;
        # $self->SUPER::DESTROY(@_);
  }
  
  #===============================================================================
  sub overload_table {
      (
          '${} dir' => 'overload_as_scalar',
          '@{} dir' => 'overload_as_array',
          '%{} dir' => 'overload_as_hash',
      )
  }
  
  sub overload_as_scalar {
      \ $_[1];
  }
  
  sub overload_as_array {
      [ $_[1]->all ];
  }
  
  sub overload_as_hash {
      +{
          map {
              (my $name = $_->pathname) =~ s/.*[\/\\]//;
              ($name, $_);
          } $_[1]->all
      };
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::Dir - Directory Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_DIR

$fatpacked{"IO/All/FTP.pm"} = <<'IO_ALL_FTP';
  package IO::All::FTP;
  use strict;
  use warnings;
  our $VERSION = '0.14';
  use IO::All::LWP '-base';
  
  const type => 'ftp';
  
  sub ftp { my $self=shift; $self->lwp_init(__PACKAGE__, @_) }
  
  1;
  
  __END__
  
  =head1 NAME
  
  IO::All::FTP - Extends IO::All to FTP URLs
  
  =head1 SYNOPSIS
  
      use IO::All;
  
      "hello world\n" > io('ftp://localhost/test/x');  # save to FTP
      io('ftp//example.org/pub/xyz') > io('xyz');      # GET to file
  
      # two ways of getting a file with a password:
      $content < io('ftp://me:secret@example.org/xyz');
      $content < io('ftp://example.org/xyz')->user('me')->password('secret');
  
  =head1 DESCRIPTION
  
  This module extends IO::All for dealing with FTP URLs.
  Note that you don't need to use it explicitly, as it is autoloaded by
  L<IO::All> whenever it sees something that looks like an FTP URL.
  
  =head1 METHODS
  
  This is a subclass of L<IO::All::LWP>. The only new method is C<ftp>, which
  can be used to create a blank L<IO::All::FTP> object; or it can also take an
  FTP URL as a parameter. Note that in most cases it is simpler just to call
  io('ftp//example.com'), which calls the C<ftp> method automatically.
  
  =head1 OPERATOR OVERLOADING
  
  The same operators from IO::All may be used. < GETs an FTP URL; > PUTs to
  an FTP URL.
  
  =head1 SEE ALSO
  
  L<IO::All::LWP>, L<IO::All>, L<LWP>.
  
  =head1 AUTHORS
  
  Ivan Tubert-Brohman <itub@cpan.org> and 
  Brian Ingerson <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2007. Ivan Tubert-Brohman and Brian Ingerson. All rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See L<http://www.perl.com/perl/misc/Artistic.html>
  
  =cut
  
IO_ALL_FTP

$fatpacked{"IO/All/File.pm"} = <<'IO_ALL_FILE';
  package IO::All::File;
  use strict;
  use warnings;
  use IO::All::Filesys -base;
  use IO::All -base;
  use IO::File;
  
  #===============================================================================
  const type => 'file';
  field tied_file => undef;
  
  #===============================================================================
  sub file {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->name(shift) if @_;
      return $self->_init;
  }
  
  sub file_handle {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->_handle(shift) if @_;
      return $self->_init;
  }
  
  #===============================================================================
  sub assert_filepath {
      my $self = shift;
      my $name = $self->pathname
        or return;
      my $directory;
      (undef, $directory) = File::Spec->splitpath($self->pathname);
      $self->assert_dirpath($directory);
  }
  
  sub assert_open_backwards {
      my $self = shift;
      return if $self->is_open;
      require File::ReadBackwards;
      my $file_name = $self->pathname;
      my $io_handle = File::ReadBackwards->new($file_name)
        or $self->throw("Can't open $file_name for backwards:\n$!");
      $self->io_handle($io_handle);
      $self->is_open(1);
  }
  
  sub assert_open {
      my $self = shift;
      return if $self->is_open;
      $self->mode(shift) unless $self->mode;
      $self->open;
  }
  
  sub assert_tied_file {
      my $self = shift;
      return $self->tied_file || do {
          eval {require Tie::File};
          $self->throw("Tie::File required for file array operations:\n$@")
            if $@;
          my $array_ref = do { my @array; \@array };
          my $name = $self->pathname;
          my @options = $self->_rdonly ? (mode => O_RDONLY) : ();
          push @options, (recsep => "\n");
          tie @$array_ref, 'Tie::File', $name, @options;
          $self->throw("Can't tie 'Tie::File' to '$name':\n$!")
            unless tied @$array_ref;
          $self->tied_file($array_ref);
      };
  }
  
  sub open {
      my $self = shift;
      $self->is_open(1);
      $self->assert_filepath if $self->_assert;
      my ($mode, $perms) = @_;
      $self->mode($mode) if defined $mode;
      $self->mode('<') unless defined $self->mode;
      $self->perms($perms) if defined $perms;
      my @args = ($self->mode);
      push @args, $self->perms if defined $self->perms;
      if (defined $self->pathname) {
          $self->io_handle(IO::File->new);
          $self->io_handle->open($self->pathname, @args)
            or $self->throw($self->open_msg);
      }
      elsif (defined $self->_handle and
             not $self->io_handle->opened
            ) {
          # XXX Not tested
          $self->io_handle->fdopen($self->_handle, @args);
      }
      $self->set_lock;
      $self->set_binmode;
  }
  
  my %mode_msg = (
      '>' => 'output',
      '<' => 'input',
      '>>' => 'append',
  );
  sub open_msg {
      my $self = shift;
      my $name = defined $self->pathname
        ? " '" . $self->pathname . "'"
        : '';
      my $direction = defined $mode_msg{$self->mode}
        ? ' for ' . $mode_msg{$self->mode}
        : '';
      return qq{Can't open file$name$direction:\n$!};
  }
  
  #===============================================================================
  sub close {
      my $self = shift;
      return unless $self->is_open;
      $self->is_open(0);
      my $io_handle = $self->io_handle;
      $self->unlock;
      $self->io_handle(undef);
      $self->mode(undef);
      if (my $tied_file = $self->tied_file) {
          if (ref($tied_file) eq 'ARRAY') {
              untie @$tied_file;
          }
          else {
              untie %$tied_file;
          }
          $self->tied_file(undef);
          return 1;
      }
      $io_handle->close(@_)
        if defined $io_handle;
      return $self;
  }
  
  sub empty {
      my $self = shift;
      -z $self->pathname;
  }
  
  sub filepath {
      my $self = shift;
      my ($volume, $path) = $self->splitpath;
      return File::Spec->catpath($volume, $path, '');
  }
  
  sub getline_backwards {
      my $self = shift;
      $self->assert_open_backwards;
      return $self->io_handle->readline;
  }
  
  sub getlines_backwards {
      my $self = shift;
      my @lines;
      while (defined (my $line = $self->getline_backwards)) {
          push @lines, $line;
      }
      return @lines;
  }
  
  sub head {
      my $self = shift;
      my $lines = shift || 10;
      my @return;
      $self->close;
      while ($lines--) {
          push @return, ($self->getline or last);
      }
      $self->close;
      return wantarray ? @return : join '', @return;
  }
  
  sub tail {
      my $self = shift;
      my $lines = shift || 10;
      my @return;
      $self->close;
      while ($lines--) {
          unshift @return, ($self->getline_backwards or last);
      }
      $self->close;
      return wantarray ? @return : join '', @return;
  }
  
  sub touch {
      my $self = shift;
      return $self->SUPER::touch(@_)
        if -e $self->pathname;
      return $self if $self->is_open;
      my $mode = $self->mode;
      $self->mode('>>')->open->close;
      $self->mode($mode);
      return $self;
  }
  
  sub unlink {
      my $self = shift;
      unlink $self->pathname;
  }
  
  #===============================================================================
  sub overload_table {
      my $self = shift;
      (
          $self->SUPER::overload_table(@_),
          'file > file' => 'overload_file_to_file',
          'file < file' => 'overload_file_from_file',
          '${} file' => 'overload_file_as_scalar',
          '@{} file' => 'overload_file_as_array',
          '%{} file' => 'overload_file_as_dbm',
      )
  }
  
  sub overload_file_to_file {
      require File::Copy;
      File::Copy::copy($_[1]->pathname, $_[2]->pathname);
      $_[2];
  }
  
  sub overload_file_from_file {
      require File::Copy;
      File::Copy::copy($_[2]->pathname, $_[1]->pathname);
      $_[1];
  }
  
  sub overload_file_as_array {
      $_[1]->assert_tied_file;
  }
  
  sub overload_file_as_dbm {
      $_[1]->dbm
        unless $_[1]->isa('IO::All::DBM');
      $_[1]->assert_open;
  }
  
  sub overload_file_as_scalar {
      my $scalar = $_[1]->scalar;
      return \$scalar;
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::File - File Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_FILE

$fatpacked{"IO/All/Filesys.pm"} = <<'IO_ALL_FILESYS';
  package IO::All::Filesys;
  use strict;
  use warnings;
  use IO::All::Base -base;
  use Fcntl qw(:flock);
  
  sub exists { my $self = shift; -e $self->name }
  
  sub filename {
      my $self = shift;
      my $filename;
      (undef, undef, $filename) = $self->splitpath;
      return $filename;
  }
  
  sub is_absolute {
      my $self = shift;
      return *$self->{is_absolute} = shift if @_;
      return *$self->{is_absolute}
        if defined *$self->{is_absolute};
      *$self->{is_absolute} = IO::All::is_absolute($self) ? 1 : 0;
  }
  
  sub is_executable { my $self = shift; -x $self->name }
  sub is_readable { my $self = shift; -r $self->name }
  sub is_writable { my $self = shift; -w $self->name }
  {
      no warnings 'once';
      *is_writeable = \&is_writable;
  }
  
  sub pathname {
      my $self = shift;
      return *$self->{pathname} = shift if @_;
      return *$self->{pathname} if defined *$self->{pathname};
      return $self->name;
  }
  
  sub relative {
      my $self = shift;
      $self->pathname(File::Spec->abs2rel($self->pathname))
        if $self->is_absolute;
      $self->is_absolute(0);
      return $self;
  }
  
  sub rename {
      my $self = shift;
      my $new = shift;
      rename($self->name, "$new")
        ? UNIVERSAL::isa($new, 'IO::All')
          ? $new
          : $self->constructor->($new)
        : undef;
  }
  
  sub set_lock {
      my $self = shift;
      return unless $self->_lock;
      my $io_handle = $self->io_handle;
      my $flag = $self->mode =~ /^>>?$/
      ? LOCK_EX
      : LOCK_SH;
      flock $io_handle, $flag;
  }
  
  sub stat {
      my $self = shift;
      return IO::All::stat($self, @_)
        if $self->is_open;
        CORE::stat($self->pathname);
  }
  
  sub touch {
      my $self = shift;
      $self->utime;
  }
  
  sub unlock {
      my $self = shift;
      flock $self->io_handle, LOCK_UN
        if $self->_lock;
  }
  
  sub utime {
      my $self = shift;
      my $atime = shift;
      my $mtime = shift;
      $atime = time unless defined $atime;
      $mtime = $atime unless defined $mtime;
      utime($atime, $mtime, $self->name);
      return $self;
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::Filesys - File System Methods Mixin for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
IO_ALL_FILESYS

$fatpacked{"IO/All/HTTP.pm"} = <<'IO_ALL_HTTP';
  package IO::All::HTTP;
  use strict;
  use warnings;
  our $VERSION = '0.14';
  use IO::All::LWP '-base';
  use URI::http; 
  use URI::_userpass; 
  push @URI::http::ISA, 'URI::_userpass';
  
  const type => 'http';
  
  sub http { my $self=shift; $self->lwp_init(__PACKAGE__, @_) }
  
  1;
  
  __END__
  
  =head1 NAME
  
  IO::All::LWP - Extends IO::All to HTTP URLs
  
  =head1 SYNOPSIS
  
      use IO::All;
  
      $content < io('http://example.org');             # GET webpage into scalar
      io('http://example.org') > io('index.html');     # GET to file
      "hello\n" > io('http://example.org/index.html'); # PUT webpage
  
      # two ways of getting a page with a password:
      $content < io('http://me:secret@example.org');
      $content < io('http://example.org')->user('me')->password('secret');
  
  =head1 DESCRIPTION
  
  This module extends L<IO::All> for dealing with HTTP URLs. 
  Note that you don't need to use it explicitly, as it is autoloaded by
  L<IO::All> whenever it sees something that looks like an HTTP URL.
  
  The SYNOPSIS shows some simple typical examples, but there are many other
  interesting combinations with other IO::All features! For example, you can get
  an HTTP URL and write the content to a socket, or to an FTP URL, of to a DBM
  file.
  
  =head1 METHODS
  
  This is a subclass of L<IO::All::LWP>. The only new method is C<http>, which
  can be used to create a blank L<IO::All::HTTP> object; or it can also take an
  HTTP URL as a parameter. Note that in most cases it is simpler just to call
  io('http://example.com'), which calls the C<http> method automatically.
  
  =head1 OPERATOR OVERLOADING
  
  The same operators from IO::All may be used. < GETs an HTTP URL; > PUTs to
  an HTTP URL.
  
  =head1 SEE ALSO
  
  L<IO::All>, L<IO::All::LWP>, L<LWP>.
  
  =head1 AUTHORS
  
  Ivan Tubert-Brohman <itub@cpan.org> and 
  Brian Ingerson <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2007. Ivan Tubert-Brohman and Brian Ingerson. All rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See L<http://www.perl.com/perl/misc/Artistic.html>
  
  =cut
  
IO_ALL_HTTP

$fatpacked{"IO/All/HTTPS.pm"} = <<'IO_ALL_HTTPS';
  package IO::All::HTTPS;
  use strict;
  use warnings;
  our $VERSION = '0.14';
  use IO::All::HTTP '-base';
  
  const type => 'https';
  
  sub https { my $self=shift;$self->lwp_init(__PACKAGE__, @_) }
  
  1;
  
  __END__
  
  =head1 NAME
  
  IO::All::HTTPS - Extends IO::All for HTTPS URLs
  
  =head1 SYNOPSIS
  
      use IO::All;
  
      $content < io('https://example.org');   # GET webpage
  
      # two ways of getting a page with a password:
      $content < io('https://me:secret@example.org');
      $content < io('https://example.org')->user('me')->password('secret');
  
  
  =head1 DESCRIPTION
  
  This module extends L<IO::All> for dealing with HTTPS URLs. 
  Note that you don't need to use it explicitly, as it is autoloaded by
  L<IO::All> whenever it sees something that looks like an HTTPS URL.
  
  The SYNOPSIS shows some simple typical examples, but there are many other
  interesting combinations with other IO::All features! For example, you can get
  an HTTPS URL and write the content to a socket, or to an FTP URL, of to a DBM
  file.
  
  =head1 METHODS
  
  This is a subclass of L<IO::All::LWP>. The only new method is C<https>, which
  can be used to create a blank L<IO::All::HTTPS> object; or it can also take an
  HTTPS URL as a parameter. Note that in most cases it is simpler just to call
  io('https://example.com'), which calls the C<https> method automatically.
  
  =head1 OPERATOR OVERLOADING
  
  The same operators from IO::All may be used. < GETs an HTTPS URL; > PUTs to
  an HTTPS URL.
  
  =head1 SEE ALSO
  
  L<IO::All>, L<IO::All::LWP>, L<LWP>.
  
  =head1 AUTHORS
  
  Ivan Tubert-Brohman <itub@cpan.org> and 
  Brian Ingerson <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2007. Ivan Tubert-Brohman and Brian Ingerson. All rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See L<http://www.perl.com/perl/misc/Artistic.html>
  
  =cut
  
IO_ALL_HTTPS

$fatpacked{"IO/All/LWP.pm"} = <<'IO_ALL_LWP';
  package IO::All::LWP;
  require 5.008;
  use strict;
  use warnings;
  our $VERSION = '0.14';
  use IO::All 0.30 '-base';
  use LWP::UserAgent;
  use IO::Handle;
  
  my $DEFAULT_UA = LWP::UserAgent->new(env_proxy => 1);
  
  field 'response';
  field 'content';
  field 'put_content';
  
  sub lwp_init {
      my $self = shift;
      bless $self, shift;
      $self->name(shift) if @_;
      return $self->_init;
  }
  
  sub ua {
      my $self = shift;
      if (@_) {
          *$self->{ua} = ref($_[0]) ? shift :
              LWP::UserAgent->new(@_);
          return $self;
      } else {
          *$self->{ua} ||= $DEFAULT_UA;
      }
  }
  
  sub uri {
      my $self = shift;
      *$self->{uri} = ref($_[0]) ? shift : URI->new(shift)
        if @_;
      return *$self->{uri}
        if defined *$self->{uri};
      *$self->{uri} = URI->new($self->name);
  }
      
  sub user {
      my $self = shift;
      $self->uri->user(@_);
      return $self;
  }
  
  sub password {
      my $self = shift;
      $self->uri->password(@_);
      return $self;
  }
  
  sub get {
      my $self = shift;
      my $request = shift || HTTP::Request->new('GET', $self->uri);
      $self->request($request);
  }
  
  sub put {
      my $self = shift;
      my $request = (@_ and ref $_[0])
      ? $_[0]
      : do {
          my $content = @_ ? shift : $self->content;
          HTTP::Request->new(PUT => $self->uri, undef, $content);
      };
      $self->request($request);
      $self->is_open(0);
  }
  
  sub request {
      my $self = shift;
      $self->response($self->ua->request(shift));
  }
  
  sub open {
      my $self = shift;
      $self->is_open(1);
      my $mode = @_ ? shift : $self->mode ? $self->mode : '<';
      $self->mode($mode);
      my $fh;
      if ($mode eq '<') {
          $self->content($self->get->content);
          CORE::open $fh, "<", \ $self->content;
      } 
      elsif ($mode eq '>') {
          $self->put_content(\ do{ my $x = ''});
          CORE::open $fh, ">", $self->put_content;
      } 
      $self->io_handle($fh);
      return $self;
  }
  
  sub close {
      my $self = shift;
      if ($self->is_open and defined $self->mode and $self->mode eq '>') {
          $self->content(${$self->put_content});
          $self->put;
      }
      $self->SUPER::close;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  IO::All::LWP - IO::All interface to LWP
  
  =head1 SYNOPSIS
  
      use IO::All;
  
      "hello world\n" > io('ftp://localhost/test/x');   # save to FTP
      $content < io('http://example.org');              # GET webpage
  
      io('http://example.org') > io('index.html');      # save webpage
  
  =head1 DESCRIPTION
  
  This module acts as glue between L<IO::All> and L<LWP>, so that files can be
  read and written through the network using the convenient L<IO:All> interface.
  Note that this module is not C<use>d directly: you just use L<IO::All>, which
  knows when to autoload L<IO::All::HTTP>, L<IO::All::HTTPS>, L<IO::All::FTP>, or
  L<IO::All::Gopher>, which implement the specific protocols based on
  L<IO::All::LWP>.
  
  =head1 EXECUTION MODEL
  
  B<GET requests>. When the IO::All object is opened, the URI is fetched and
  stored by the object in an internal file handle. It can then be accessed like
  any other file via the IO::All methods and operators, it can be tied, etc.
  
  B<PUT requests>. When the IO::All object is opened, an internal file handle is
  created. It is possible to that file handle using the various IO::All methods
  and operators, it can be tied, etc. If $io->put is not called explicitly, when
  the IO::All object is closed, either explicitly via $io->close or automatically
  upon destruction, the actual PUT request is made.
  
  The bad news is that the whole file is stored in memory after getting it or
  before putting it. This may cause problems if you are dealing with
  multi-gigabyte files!
  
  =head1 METHODS
  
  The simplest way of doing things is via the overloaded operators > and <, as
  shown in the SYNOPSIS. These take care of automatically opening and closing the
  files and connections as needed. However, various methods are available to
  provide a finer degree of control. 
  
  This is a subclass of L<IO::All>. In addition to the inherited methods, the 
  following methods are available:
  
  =over
  
  =item * ua
  
  Set or get the user agent object (L<LWP::UserAgent> or a subclass). If called
  with a list, the list is passed to LWP::UserAgent->new. If called with an
  object, the object is used directly as the user agent. Note that there is a 
  default user agent if no user agent is specified.
  
  =item * uri
  
  Set or get the URI. It can take either a L<URI> object or a string, and 
  it returns an L<URI> object. Note that calling this method overrides the user
  and password fields, because URIs can contain authentication information.
  
  =item * user
  
  Set or get the user name for authentication. Note that the user name (and the
  password) can also be set as part of the URL, as in
  "http://me:secret@example.com/".
  
  =item * password
  
  Set or get the password for authentication. Note that the password can also
  be set as part of the URL, as discussed above.
  
  =item * get
  
  GET the current URI using LWP. Or, if called with an L<HTTP::Request> object as
  a parameter, it does that request instead. It returns the L<HTTP::Response>
  object.
  
  =item * put
  
  PUT to the current URI using LWP. If called with an L<HTTP::Request> object, it
  does that request instead. If called with a scalar, it PUTs that as the
  content to the current URI, instead of the current accumulated content.
  
  =item * response
  
  Return the L<HTTP::Response> object.
  
  =item * request
  
  Does an LWP request. It requires an L<HTTP::Request> object as a parameter.
  Returns an L<HTTP::Response> object.
  
  =item * open
  
  Overrides the C<open> method from L<IO::All>. It takes care of GETting the 
  content, or of setting up the internal buffer for PUTting. Just like the
  C<open> method from L<IO::All>, it can take a mode: '<' for GET and 
  '>' for PUT.
  
  =item * close
  
  Overrides the C<close> method from L<IO::All>. It takes care of PUTting
  the content.
  
  =back
  
  =head1 DEPENDENCIES
  
  This module uses L<LWP> for all the heavy lifting. It also requires perl-5.8.0
  or a more recent version.
  
  =head1 SEE ALSO
  
  L<IO::All>, L<LWP>, L<IO::All::HTTP>, L<IO::All::FTP>.
  
  =head1 AUTHORS
  
  Ivan Tubert-Brohman <itub@cpan.org> and 
  Brian Ingerson <ingy@cpan.org>
  
  Thanks to Sergey Gleizer for the ua method.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2007. Ivan Tubert-Brohman and Brian Ingerson. All rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See L<http://www.perl.com/perl/misc/Artistic.html>
  
  =cut
  
IO_ALL_LWP

$fatpacked{"IO/All/Link.pm"} = <<'IO_ALL_LINK';
  package IO::All::Link;
  use strict;
  use warnings;
  use IO::All::File -base;
  
  const type => 'link';
  
  sub link {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->name(shift) if @_;
      $self->_init;
  }
  
  sub readlink {
      my $self = shift;
      $self->constructor->(CORE::readlink($self->name));
  }
  
  sub symlink {
      my $self = shift;
      my $target = shift;
      $self->assert_filepath if $self->_assert;
      CORE::symlink($target, $self->pathname);
  }
  
  sub AUTOLOAD {
      my $self = shift;
      our $AUTOLOAD;
      (my $method = $AUTOLOAD) =~ s/.*:://;
      my $target = $self->target;
      unless ($target) {
          $self->throw("Can't call $method on symlink");
          return;
      }
      $target->$method(@_);
  }
  
  sub target {
      my $self = shift;
      return *$self->{target} if *$self->{target};
      my %seen;
      my $link = $self;
      my $new;
      while ($new = $link->readlink) {
          my $type = $new->type or return;
          last if $type eq 'file';
          last if $type eq 'dir';
          return unless $type eq 'link';
          return if $seen{$new->name}++;
          $link = $new;
      }
      *$self->{target} = $new;
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::Link - Symbolic Link Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_LINK

$fatpacked{"IO/All/MLDBM.pm"} = <<'IO_ALL_MLDBM';
  package IO::All::MLDBM;
  use strict;
  use warnings;
  use IO::All::DBM -base;
  
  field _serializer => 'Data::Dumper';
  
  sub mldbm {
      my $self = shift;
      bless $self, __PACKAGE__;
      my ($serializer) = grep { /^(Storable|Data::Dumper|FreezeThaw)$/ } @_;
      $self->_serializer($serializer) if defined $serializer;
      my @dbm_list = grep { not /^(Storable|Data::Dumper|FreezeThaw)$/ } @_;
      $self->_dbm_list([@dbm_list]);
      return $self;
  }
  
  sub tie_dbm {
      my $self = shift;
      my $filename = $self->name;
      my $dbm_class = $self->_dbm_class;
      my $serializer = $self->_serializer;
      eval "use MLDBM qw($dbm_class $serializer)";
      $self->throw("Can't open '$filename' as MLDBM:\n$@") if $@;
      my $hash;
      my $db = tie %$hash, 'MLDBM', $filename, $self->mode, $self->perms,
          @{$self->_dbm_extra}
        or $self->throw("Can't open '$filename' as MLDBM file:\n$!");
      $self->add_utf8_dbm_filter($db)
        if $self->_utf8;
      $self->tied_file($hash);
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::MLDBM - MLDBM Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_MLDBM

$fatpacked{"IO/All/Pipe.pm"} = <<'IO_ALL_PIPE';
  package IO::All::Pipe;
  use strict;
  use warnings;
  use IO::All -base;
  use IO::File;
  
  const type => 'pipe';
  
  sub pipe {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->name(shift) if @_;
      return $self->_init;
  }
  
  sub assert_open {
      my $self = shift;
      return if $self->is_open;
      $self->mode(shift) unless $self->mode;
      $self->open;
  }
  
  sub open {
      my $self = shift;
      $self->is_open(1);
      require IO::Handle;
      $self->io_handle(IO::Handle->new)
        unless defined $self->io_handle;
      my $command = $self->name;
      $command =~ s/(^\||\|$)//;
      my $mode = shift || $self->mode || '<';
      my $pipe_mode =
        $mode eq '>' ? '|-' :
        $mode eq '<' ? '-|' :
        $self->throw("Invalid usage mode '$mode' for pipe");
      CORE::open($self->io_handle, $pipe_mode, $command);
      $self->set_binmode;
  }
  
  my %mode_msg = (
      '>' => 'output',
      '<' => 'input',
      '>>' => 'append',
  );
  sub open_msg {
      my $self = shift;
      my $name = defined $self->name
        ? " '" . $self->name . "'"
        : '';
      my $direction = defined $mode_msg{$self->mode}
        ? ' for ' . $mode_msg{$self->mode}
        : '';
      return qq{Can't open pipe$name$direction:\n$!};
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::Pipe - Pipe Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_PIPE

$fatpacked{"IO/All/STDIO.pm"} = <<'IO_ALL_STDIO';
  package IO::All::STDIO;
  use strict;
  use warnings;
  use IO::All -base;
  use IO::File;
  
  const type => 'stdio';
  
  sub stdio {
      my $self = shift;
      bless $self, __PACKAGE__;
      return $self->_init;
  }
  
  sub stdin {
      my $self = shift;
      $self->open('<');
      return $self;
  }
  
  sub stdout {
      my $self = shift;
      $self->open('>');
      return $self;
  }
  
  sub stderr {
      my $self = shift;
      $self->open_stderr;
      return $self;
  }
  
  sub open {
      my $self = shift;
      $self->is_open(1);
      my $mode = shift || $self->mode || '<';
      my $fileno = $mode eq '>'
      ? fileno(STDOUT)
      : fileno(STDIN);
      $self->io_handle(IO::File->new);
      $self->io_handle->fdopen($fileno, $mode);
      $self->set_binmode;
  }
  
  sub open_stderr {
      my $self = shift;
      $self->is_open(1);
      $self->io_handle(IO::File->new);
      $self->io_handle->fdopen(fileno(STDERR), '>') ? $self : 0;
  }
  
  # XXX Add overload support
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::STDIO - STDIO Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_STDIO

$fatpacked{"IO/All/Socket.pm"} = <<'IO_ALL_SOCKET';
  package IO::All::Socket;
  use strict;
  use warnings;
  use IO::All -base;
  use IO::Socket;
  
  const type => 'socket';
  field _listen => undef;
  option 'fork';
  const domain_default => 'localhost';
  chain domain => undef;
  chain port => undef;
  proxy_open 'recv';
  proxy_open 'send';
  
  sub socket {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->name(shift) if @_;
      return $self->_init;
  }
  
  sub socket_handle {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->_handle(shift) if @_;
      return $self->_init;
  }
  
  sub accept {
      my $self = shift;
      use POSIX ":sys_wait_h";
      sub REAPER {
          while (waitpid(-1, WNOHANG) > 0) {}
          $SIG{CHLD} = \&REAPER;
      }
      local $SIG{CHLD};
      $self->_listen(1);
      $self->assert_open;
      my $server = $self->io_handle;
      my $socket;
      while (1) {
          $socket = $server->accept;
          last unless $self->_fork;
          next unless defined $socket;
          $SIG{CHLD} = \&REAPER;
          my $pid = CORE::fork;
          $self->throw("Unable to fork for IO::All::accept")
            unless defined $pid;
          last unless $pid;
          close $socket;
          undef $socket;
      }
      close $server if $self->_fork;
      my $io = ref($self)->new->socket_handle($socket);
      $io->io_handle($socket);
      $io->is_open(1);
      return $io;
  }
  
  sub shutdown {
      my $self = shift;
      my $how = @_ ? shift : 2;
      my $handle = $self->io_handle;
      $handle->shutdown(2)
        if defined $handle;
  }
  
  sub assert_open {
      my $self = shift;
      return if $self->is_open;
      $self->mode(shift) unless $self->mode;
      $self->open;
  }
  
  sub open {
      my $self = shift;
      return if $self->is_open;
      $self->is_open(1);
      $self->get_socket_domain_port;
      my @args = $self->_listen
      ? (
          LocalAddr => $self->domain,
          LocalPort => $self->port,
          Proto => 'tcp',
          Listen => 1,
          Reuse => 1,
      )
      : (
          PeerAddr => $self->domain,
          PeerPort => $self->port,
          Proto => 'tcp',
      );
      my $socket = IO::Socket::INET->new(@args)
        or $self->throw("Can't open socket");
      $self->io_handle($socket);
      $self->set_binmode;
  }
  
  sub get_socket_domain_port {
      my $self = shift;
      my ($domain, $port);
      ($domain, $port) = split /:/, $self->name
        if defined $self->name;
      $self->domain($domain) unless defined $self->domain;
      $self->domain($self->domain_default) unless $self->domain;
      $self->port($port) unless defined $self->port;
      return $self;
  }
  
  sub overload_table {
      my $self = shift;
      (
          $self->SUPER::overload_table(@_),
          '&{} socket' => 'overload_socket_as_code',
      )
  }
  
  sub overload_socket_as_code {
      my $self = shift;
      sub {
          my $coderef = shift;
          while ($self->is_open) {
              $_ = $self->getline;
              &$coderef($self);
          }
      }
  }
  
  sub overload_any_from_any {
      my $self = shift;
      $self->SUPER::overload_any_from_any(@_);
      $self->close;
  }
  
  sub overload_any_to_any {
      my $self = shift;
      $self->SUPER::overload_any_to_any(@_);
      $self->close;
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::Socket - Socket Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008, 2010. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_SOCKET

$fatpacked{"IO/All/String.pm"} = <<'IO_ALL_STRING';
  package IO::All::String;
  use strict;
  use warnings;
  use IO::All -base;
  use IO::String;
  
  const type => 'string';
  proxy 'string_ref';
  
  sub string {
      my $self = shift;
      bless $self, __PACKAGE__;
      $self->_init;
  }
  
  sub open {
      my $self = shift;
      $self->io_handle(IO::String->new);
      $self->set_binmode;
      $self->is_open(1);
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::String - String IO Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson. All rights reserved.
  
  Copyright (c) 2006, 2008. Ingy döt Net. All rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_STRING

$fatpacked{"IO/All/Temp.pm"} = <<'IO_ALL_TEMP';
  package IO::All::Temp;
  use strict;
  use warnings;
  use IO::All::File -base;
  
  sub temp {
      my $self = shift;
      bless $self, __PACKAGE__;
      my $temp_file = IO::File::new_tmpfile()
        or $self->throw("Can't create temporary file");
      $self->io_handle($temp_file);
      $self->error_check;
      $self->autoclose(0);
      $self->is_open(1);
      return $self;
  }
  
  =encoding utf8
  
  =head1 NAME
  
  IO::All::Temp - Temporary File Support for IO::All
  
  =head1 SYNOPSIS
  
  See L<IO::All>.
  
  =head1 DESCRIPTION
  
  =head1 AUTHOR
  
  Ingy döt Net <ingy@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2004. Brian Ingerson.
  
  Copyright (c) 2006, 2008. Ingy döt Net.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  See http://www.perl.com/perl/misc/Artistic.html
  
  =cut
  
  1;
IO_ALL_TEMP

$fatpacked{"Installer.pm"} = <<'INSTALLER';
  package Installer;
  BEGIN {
    $Installer::AUTHORITY = 'cpan:GETTY';
  }
  {
    $Installer::VERSION = '0.006';
  }
  # ABSTRACT: What does it do? It installs stuff....
  
  use strict;
  use warnings;
  use Installer::Target;
  
  our @functions = qw(
  
    run
    url
    file
    perl
    cpanm
    pip
  
  );
  
  sub import {
    my $pkg = caller;
    {
      no strict 'refs';
      *{"$pkg\::install_to"} = sub {
        my ( $target_directory, $installer_code ) = @_;
        my $installer_target = Installer::Target->new(
          target_directory => $target_directory,
          installer_code => $installer_code,
        );
        $installer_target->installation;
      };
    }
    for my $command (@functions) {
      my $function = 'install_'.$command;
      no strict 'refs';
      *{"$pkg\::$command"} = sub {
        die "Not inside installation" unless defined $Installer::Target::current;
        $Installer::Target::current->$function(@_);
      };
    }
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Installer - What does it do? It installs stuff....
  
  =head1 VERSION
  
  version 0.006
  
  =head1 SYNOPSIS
  
    use Installer;
  
    install_to $ENV{HOME}.'/myenv' => sub {
      perl "5.18.1";
      url "http://ftp.postgresql.org/pub/source/v9.2.4/postgresql-9.2.4.tar.gz", with => {
        pgport => 15432,
      };
      url "http://download.osgeo.org/gdal/1.10.1/gdal-1.10.1.tar.gz";
      url "http://download.osgeo.org/geos/geos-3.4.2.tar.bz2";
      url "http://download.osgeo.org/postgis/source/postgis-2.1.0.tar.gz", custom_test => sub {
        $_[0]->run($_[0]->unpack_path,'make','check');
      };
      cpanm "DBD::Pg";
    };
  
  Or in class usage (not suggested):
  
    use Installer::Target;
  
    my $target = Installer::Target->new(
      target_directory => $ENV{HOME}.'/myenv',
      output_code => sub {
        your_own_logger(join(" ",@_));
      },
    );
  
    $target->prepare_installation;
    $target->install_perl("5.18.1");
    $target->install_file("postgresql-9.2.4.tar.gz", with => {
      pgport => 15432,
    });
    $target->install_cpanm("DBD::Pg","Plack");
    # will run in the target directory
    $target->install_run("command","--with-args");
    $target->finish_installation;
  
    # to get the filename of the log produced on the installation
    print $target->log_filename;
  
    my $other_usage = Installer::Target->new(
      target_directory => $ENV{HOME}.'/otherenv',
      installer_code => sub {
        $_[0]->install_perl("5.18.1");
        $_[0]->install_cpanm("Task::Kensho");
      },
    );
  
    $other_usage->installation;
  
  =head1 DESCRIPTION
  
  See L<installer> for more information.
  
  B<TOTALLY BETA, PLEASE TEST :D>
  
  =encoding utf8
  
  =head1 AUTHOR
  
  Torsten Raudssus <torsten@raudss.us>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Torsten Raudssus.
  
  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
INSTALLER

$fatpacked{"Installer/Software.pm"} = <<'INSTALLER_SOFTWARE';
  package Installer::Software;
  BEGIN {
    $Installer::Software::AUTHORITY = 'cpan:GETTY';
  }
  {
    $Installer::Software::VERSION = '0.006';
  }
  # ABSTRACT: A software installation
  
  use Moo;
  use IO::All;
  use IO::All::LWP;
  use JSON_File;
  use Path::Class;
  use File::chdir;
  use Archive::Extract;
  use namespace::clean;
  
  has target => (
    is => 'ro',
    required => 1,
  );
  sub log_print { shift->target->log_print(@_) }
  sub run { shift->target->run(@_) }
  sub target_directory { shift->target->target->stringify }
  sub target_path { shift->target->target_path(@_) }
  sub target_file { shift->target->target_file(@_) }
  
  has archive_url => (
    is => 'ro',
    predicate => 1,
  );
  
  has archive => (
    is => 'ro',
    predicate => 1,
  );
  
  for (qw( custom_configure custom_test post_install export_sh )) {
    has $_ => (
      is => 'ro',
      predicate => 1,
    );
  }
  
  for (qw( with enable disable without )) {
    has $_ => (
      is => 'ro',
      predicate => 1,
    );
  }
  
  has alias => (
    is => 'ro',
    lazy => 1,
    default => sub {
      my ( $self ) = @_;
      if ($self->has_archive_url) {
        return (split('-',(split('/',io($self->archive_url)->uri->path))[-1]))[0];
      } elsif ($self->has_archive) {
        return (split('-',(split('/',$self->archive))[-1]))[0];
      }
      die "Can't produce an alias for this sofware";
    },
  );
  
  has meta => (
    is => 'ro',
    lazy => 1,
    default => sub {
      my ( $self ) = @_;
      tie(my %meta,'JSON_File',file($self->target->installer_dir,$_[0]->alias.'.json')->stringify,, pretty => 1 );
      return \%meta;
    },
  );
  
  has testable => (
    is => 'ro',
    lazy => 1,
    default => sub { $_[0]->has_custom_test ? 1 : 0 },
  );
  
  sub installation {
    my ( $self ) = @_;
    $self->fetch;
    $self->unpack;
    $self->configure;
    $self->compile;
    $self->test if $self->testable;
    $self->install;
  }
  
  sub fetch {
    my ( $self ) = @_;
    return if defined $self->meta->{fetch};
    if ($self->has_archive_url) {
      my $sio = io($self->archive_url);
      my $filename = (split('/',$sio->uri->path))[-1];
      $self->log_print("Downloading ".$self->archive_url." as ".$filename." ...");
      my $full_filename = file($self->target->src_dir,$filename)->stringify;
      io($full_filename)->print(io($self->archive_url)->get->content);
      $self->meta->{fetch} = $full_filename;
    } elsif ($self->has_archive) {
      $self->meta->{fetch} = file($self->archive)->absolute->stringify;
    }
    die "Unable to get an archive for unpacking for this software" unless defined $self->meta->{fetch};
  }
  sub fetch_path { file(shift->meta->{fetch}) }
  
  sub unpack {
    my ( $self ) = @_;
    return if defined $self->meta->{unpack};
    $self->log_print("Extracting ".$self->fetch_path." ...");
    my $archive = Archive::Extract->new( archive => $self->fetch_path );
    local $CWD = $self->target->src_dir;
    $archive->extract;
    for (@{$archive->files}) {
      $self->target->log($_);
    }
    my $src_path = dir($archive->extract_path)->absolute->stringify;
    $self->log_print("Extracted to ".$src_path." ...");
    $self->meta->{unpack} = $src_path;
  }
  sub unpack_path { dir(shift->meta->{unpack},@_) }
  sub unpack_file { file(shift->meta->{unpack},@_) }
  
  sub run_configure {
    my ( $self, @configure_args ) = @_;
    if ($self->has_with) {
      for my $key (keys %{$self->with}) {
        my $value = $self->with->{$key};
        if (defined $value && $value ne "") {
          push @configure_args, '--with-'.$key.'='.$value;
        } else {
          push @configure_args, '--with-'.$key;
        }
      }
    }
    for my $func (qw( enable disable without )) {
      my $has_func = 'has_'.$func;
      if ($self->$has_func) {
        for my $value (@{$self->$func}) {
          push @configure_args, '--'.$func.'-'.$value;
        }
      }
    }
    $self->run($self->unpack_path,'./configure','--prefix='.$self->target_directory,@configure_args);
  }
  
  sub configure {
    my ( $self ) = @_;
    return if defined $self->meta->{configure};
    $self->log_print("Configuring ".$self->unpack_path." ...");
    if ($self->has_custom_configure) {
      $self->custom_configure->($self);
    } else {
      if (-f $self->unpack_file('autogen.sh')) {
        $self->run($self->unpack_path,'./autogen.sh');
      }
      if (-f $self->unpack_file('configure')) {
        $self->run_configure;
      } elsif (-f $self->unpack_path('setup.py')) {
        # no configure
      } elsif ($self->unpack_file('Makefile.PL')) {
        $self->run($self->unpack_path,'perl','Makefile.PL');
      }
    }
    $self->meta->{configure} = 1;
  }
  
  sub compile {
    my ( $self ) = @_;
    return if defined $self->meta->{compile};
    $self->log_print("Compiling ".$self->unpack_path." ...");
    if (-f $self->unpack_file('setup.py') and !-f $self->unpack_file('configure')) {
      $self->run($self->unpack_path,'python','setup.py','build');
    } elsif (-f $self->unpack_file('Makefile')) {
      $self->run($self->unpack_path,'make');
    }
    $self->meta->{compile} = 1;
  }
  
  sub test {
    my ( $self ) = @_;
    return if defined $self->meta->{test};
    $self->log_print("Testing ".$self->unpack_path." ...");
    if ($self->has_custom_test) {
      $self->custom_test->($self);
    } else {
      if (-f $self->unpack_file('Makefile')) {
        $self->run($self->unpack_path,'make','test');
      }
    }
    $self->meta->{test} = 1;
  }
  
  sub install {
    my ( $self ) = @_;
    return if defined $self->meta->{install};
    $self->log_print("Installing ".$self->unpack_path." ...");
    if (-f $self->unpack_file('setup.py') and !-f $self->unpack_file('configure')) {
      $self->run($self->unpack_path,'python','setup.py','install');
    } elsif (-f $self->unpack_file('Makefile')) {
      $self->run($self->unpack_path,'make','install');
    }
    $self->meta->{install} = 1;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Installer::Software - A software installation
  
  =head1 VERSION
  
  version 0.006
  
  =head1 AUTHOR
  
  Torsten Raudssus <torsten@raudss.us>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Torsten Raudssus.
  
  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
INSTALLER_SOFTWARE

$fatpacked{"Installer/Target.pm"} = <<'INSTALLER_TARGET';
  package Installer::Target;
  BEGIN {
    $Installer::Target::AUTHORITY = 'cpan:GETTY';
  }
  {
    $Installer::Target::VERSION = '0.006';
  }
  # ABSTRACT: Currently running project
  
  use Moo;
  use IO::All;
  use IPC::Open3 ();
  use Installer::Software;
  use JSON_File;
  use File::chdir;
  use CPAN::Perl::Releases qw[perl_tarballs];
  use CPAN;
  use Path::Class;
  use namespace::clean;
  
  has output_code => (
    is => 'ro',
    lazy => 1,
    default => sub { sub {
      print @_, "\n";
    } },
  );
  
  has installer_code => (
    is => 'ro',
    required => 1,
  );
  
  has target_directory => (
    is => 'ro',
    required => 1,
  );
  
  has target => (
    is => 'ro',
    lazy => 1,
    default => sub { dir($_[0]->target_directory)->absolute },
  );
  sub target_path { dir(shift->target,@_) }
  sub target_file { file(shift->target,@_) }
  
  has installer_dir => (
    is => 'ro',
    lazy => 1,
    default => sub { dir($_[0]->target,'installer') },
  );
  
  has software => (
    is => 'ro',
    lazy => 1,
    default => sub {{}},
  );
  
  has actions => (
    is => 'ro',
    lazy => 1,
    default => sub {[]},
  );
  
  has src_dir => (
    is => 'ro',
    lazy => 1,
    default => sub { dir($_[0]->target,'src') },
  );
  
  has log_filename => (
    is => 'ro',
    lazy => 1,
    default => sub { file($_[0]->installer_dir,'build.'.(time).'.log') },
  );
  
  has log_io => (
    is => 'ro',
    lazy => 1,
    default => sub { io($_[0]->log_filename) },
  );
  
  has meta => (
    is => 'ro',
    lazy => 1,
    default => sub {
      my ( $self ) = @_;
      tie(my %meta,'JSON_File',file($self->installer_dir,'meta.json')->absolute->stringify, pretty => 1);
      return \%meta;
    },
  );
  
  sub install_software {
    my ( $self, $software ) = @_;
    $self->software->{$software->alias} = $software;
    $software->installation;
    $self->meta->{software_packages_done} = [keys %{$self->software}];
    push @{$self->actions}, $software;
    $self->update_env;
    if (!defined $software->meta->{post_install} && $software->has_post_install) {
      $software->post_install->($software);
      $software->meta->{post_install} = 1;
    }
  }
  
  sub install_url {
    my ( $self, $url, %args ) = @_;
    $self->install_software(Installer::Software->new(
      target => $self,
      archive_url => $url,
      %args,
    ));
  }
  
  sub install_file {
    my ( $self, $file, %args ) = @_;
    $self->install_software(Installer::Software->new(
      target => $self,
      archive => rel2abs(catfile($file)),
      %args,
    ));
  }
  
  sub install_perl {
    my ( $self, $perl_version, %args ) = @_;
    my $hashref = perl_tarballs($perl_version);
    my $src = 'http://www.cpan.org/authors/id/'.$hashref->{'tar.gz'};
    $self->install_software(Installer::Software->new(
      target => $self,
      archive_url => $src,
      testable => 1,
      custom_configure => sub {
        my ( $self ) = @_;
        $self->run($self->unpack_path,'./Configure','-des','-Dprefix='.$self->target_directory);
      },
      post_install => sub {
        my ( $self ) = @_;
        $self->log_print("Installing App::cpanminus ...");
        my $cpanm_filename = file($self->target->installer_dir,'cpanm');
        io($cpanm_filename)->print(io('http://cpanmin.us/')->get->content);
        chmod(0755,$cpanm_filename);
        $self->run(undef,$cpanm_filename,'-L',$self->target_path('perl5'),qw(
          App::cpanminus
          local::lib
          Module::CPANfile
        ));
      },
      export_sh => sub {
        my ( $self ) = @_;
        return 'eval $( perl -I'.$self->target_path('perl5','lib','perl5').' -Mlocal::lib='.$self->target_path('perl5').' )';
      },
      %args,
    ));
  }
  
  sub install_cpanm {
    my ( $self, @modules ) = @_;
    $self->run(undef,'cpanm',@modules);
  }
  
  sub install_pip {
    my ( $self, @modules ) = @_;
    for (@modules) {
      $self->run(undef,'pip','install',$_);    
    }
  }
  
  sub setup_env {
    my ( $self ) = @_;
    if (defined $self->meta->{PATH} && @{$self->meta->{PATH}}) {
      $ENV{PATH} = (join(':',@{$self->meta->{PATH}})).':'.$ENV{PATH};
    }
    if (defined $self->meta->{LD_LIBRARY_PATH} && @{$self->meta->{LD_LIBRARY_PATH}}) {
      $ENV{LD_LIBRARY_PATH} = (join(':',@{$self->meta->{LD_LIBRARY_PATH}})).(defined $ENV{LD_LIBRARY_PATH} ? ':'.$ENV{LD_LIBRARY_PATH} : '');
    }
  }
  
  sub update_env {
    my ( $self ) = @_;
    my %seen = defined $self->meta->{seen_dirs}
      ? %{$self->meta->{seen_dirs}}
      : ();
    if (!$seen{'bin'} and -e $self->target_path('bin')) {
      my @bindirs = defined $self->meta->{PATH}
        ? @{$self->meta->{PATH}}
        : ();
      my $bindir = $self->target_path('bin')->absolute->stringify;
      push @bindirs, $bindir;
      $self->meta->{PATH} = \@bindirs;
      $ENV{PATH} = $bindir.':'.$ENV{PATH};
      $seen{'bin'} = 1;
    }
    if (!$seen{'lib'} and -e $self->target_path('lib')) {
      my @libdirs = defined $self->meta->{LD_LIBRARY_PATH}
        ? @{$self->meta->{LD_LIBRARY_PATH}}
        : ();
      my $libdir = $self->target_path('lib')->absolute->stringify;
      push @libdirs, $libdir;
      $self->meta->{LD_LIBRARY_PATH} = \@libdirs;
      $ENV{LD_LIBRARY_PATH} = $libdir.(defined $ENV{LD_LIBRARY_PATH} ? ':'.$ENV{LD_LIBRARY_PATH} : '');
      $seen{'lib'} = 1;
    }
    $self->meta->{seen_dirs} = \%seen;
  }
  
  sub install_run {
    my ( $self, @args ) = @_;
    $self->run($self->target,@args);
    push @{$self->actions}, {
      run => \@args,
    };
  }
  
  sub run {
    my ( $self, $dir, @args ) = @_;
    $dir = $self->target_path unless $dir;
    local $CWD = "$dir";
    $self->log_print("Executing in $dir: ".join(" ",@args));
    $|=1;
    my $run_log = "";
    my $pid = IPC::Open3::open3(my ( $in, $out ), undef, join(" ",@args));
    while(defined(my $line = <$out>)){
      $run_log .= $line;
      chomp($line);
      $self->log($line);
    }
    waitpid($pid, 0);
    my $status = $? >> 8;
    if ($status) {
      print $run_log;
      print "\n";
      print "     Command: ".join(" ",@args)."\n";
      print "in Directory: ".$dir."\n";
      print "exited with status $status\n\n";
      print "\n";
      die "Error on run ".$self->log_filename;
    }
  }
  
  sub log {
    my ( $self, @line ) = @_;
    $self->log_io->append(join(" ",@line),"\n");
  }
  
  sub log_print {
    my ( $self, @line ) = @_;
    $self->log("#" x 80);
    $self->log("##");
    $self->log("## ",@line);
    my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
    $self->log("## ",sprintf("%.2d.%.2d.%.4d %.2d:%.2d:%.2d",$mday,$mon,$year+1900,$hour,$min,$sec));
    $self->log("##");
    $self->log("#" x 80);
    $self->output_code->(@line);
  }
  
  sub write_export {
    my ( $self ) = @_;
    my $export_filename = $self->target_file('export.sh');
    $self->log_print("Generating ".$export_filename." ...");
    my $export_sh = "#!/bin/sh\n#\n# Installer auto generated export.sh\n#\n".("#" x 60)."\n\n";
    if (defined $self->meta->{PATH} && @{$self->meta->{PATH}}) {
      $export_sh .= 'export PATH="'.join(':',@{$self->meta->{PATH}}).':$PATH"'."\n";
    }
    if (defined $self->meta->{LD_LIBRARY_PATH} && @{$self->meta->{LD_LIBRARY_PATH}}) {
      $export_sh .= 'export LD_LIBRARY_PATH="'.join(':',@{$self->meta->{LD_LIBRARY_PATH}}).':$LD_LIBRARY_PATH"'."\n";
    }
    $export_sh .= "\n";
    for (@{$self->meta->{software_packages_done}}) {
      my $software = $self->software->{$_};
      if ($software->has_export_sh) {
        my @lines = $software->export_sh->($software);
        $export_sh .= "# export.sh addition by ".$software->alias."\n";
        $export_sh .= join("\n",@lines)."\n\n";
      }
    }
    $export_sh .= ("#" x 60)."\n";
    io($export_filename)->print($export_sh);
    chmod(0755,$export_filename);
  }
  
  our $current;
  
  sub prepare_installation {
    my ( $self ) = @_;
    die "Target directory is a file" if -f $self->target;
    $current = $self;
    $self->target->mkpath unless -d $self->target;
    $self->installer_dir->mkpath unless -d $self->installer_dir;
    $self->src_dir->mkpath unless -d $self->src_dir;
    $self->log_io->print(("#" x 80)."\nStarting new log ".(time)."\n".("#" x 80)."\n\n");
    $self->meta->{last_run} = time;
    $self->meta->{preinstall_ENV} = \%ENV;
    $self->setup_env;
  }
  
  sub finish_installation {
    my ( $self ) = @_;
    $self->write_export;
    $self->log_print("Done");
    %ENV = %{$self->meta->{preinstall_ENV}};
    delete $self->meta->{preinstall_ENV};
    $current = undef;
  }
  
  sub installation {
    my ( $self ) = @_;
    $self->prepare_installation;
    $self->installer_code->($self);
    $self->finish_installation;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Installer::Target - Currently running project
  
  =head1 VERSION
  
  version 0.006
  
  =head1 AUTHOR
  
  Torsten Raudssus <torsten@raudss.us>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Torsten Raudssus.
  
  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
INSTALLER_TARGET

$fatpacked{"JSON/MaybeXS.pm"} = <<'JSON_MAYBEXS';
  package JSON::MaybeXS;
  
  use strict;
  use warnings FATAL => 'all';
  use base qw(Exporter);
  
  our $VERSION = '1.000000';
  
  BEGIN {
    our $JSON_Class;
  
    our @err;
  
    if (eval { require Cpanel::JSON::XS; 1; }) {
      $JSON_Class = 'Cpanel::JSON::XS';
    } else {
      push @err, "Error loading Cpanel::JSON::XS: $@";
      if (eval { require JSON::PP; 1; }) {
        $JSON_Class = 'JSON::PP';
      } else {
        push @err, "Error loading JSON::PP: $@";
      }
    }
    unless ($JSON_Class) {
      die join("\n", "Couldn't load a JSON module:", @err);
    }
    $JSON_Class->import(qw(encode_json decode_json));
  }
  
  our @EXPORT = qw(encode_json decode_json JSON);
  
  sub JSON () { our $JSON_Class }
  
  1;
  
  =head1 NAME
  
  JSON::MaybeXS - use L<Cpanel::JSON::XS> with a fallback to L<JSON::PP>
  
  =head1 SYNOPSIS
  
    use JSON::MaybeXS;
  
    my $data_structure = decode_json($json_input);
  
    my $json_output = encode_json($data_structure);
  
    my $json = JSON->new;
  
  =head1 DESCRIPTION
  
  This module tries to load L<Cpanel::JSON::XS>, and if that fails instead
  tries to load L<JSON::PP>. If neither is available, an exception will be
  thrown.
  
  It then exports the C<encode_json> and C<decode_json> functions from the
  loaded module, along with a C<JSON> constant that returns the class name
  for calling C<new> on.
  
  =head1 EXPORTS
  
  All of C<encode_json>, C<decode_json> and C<JSON> are exported by default.
  
  To import only some symbols, specify them on the C<use> line:
  
    use JSON::MaybeXS qw(encode_json decode_json); # functions only
  
    use JSON::MaybeXS qw(JSON); # JSON constant only
  
  =head2 encode_json
  
  This is the C<encode_json> function provided by the selected implementation
  module, and takes a perl data stucture which is serialised to JSON text.
  
    my $json_text = encode_json($data_structure);
  
  =head2 decode_json
  
  This is the C<decode_json> function provided by the selected implementation
  module, and takes a string of JSON text to deserialise to a perl data structure.
  
    my $data_structure = decode_json($json_text);
  
  =head2 JSON
  
  The C<JSON> constant returns the selected implementation module's name for
  use as a class name - so:
  
    my $json_obj = JSON->new; # returns a Cpanel::JSON::XS or JSON::PP object
  
  and that object can then be used normally:
  
    my $data_structure = $json_obj->decode($json_text); # etc.
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  None yet. Well volunteered? :)
  
  =head1 COPYRIGHT
  
  Copyright (c) 2013 the C<JSON::MaybeXS> L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
JSON_MAYBEXS

$fatpacked{"JSON_File.pm"} = <<'JSON_FILE';
  package JSON_File;
  BEGIN {
    $JSON_File::AUTHORITY = 'cpan:GETTY';
  }
  {
    $JSON_File::VERSION = '0.003';
  }
  # ABSTRACT: Tie a hash or an array to a JSON
  
  use Moo;
  use JSON::MaybeXS;
  use Path::Class;
  use autodie;
  
  has json => (
    is => 'ro',
    lazy => 1,
    default => sub {
      my $self = shift;
      my $json = JSON->new()->utf8(1)->canonical(1);
      $json = $json->convert_blessed($self->convert_blessed) if $self->has_convert_blessed;
      $json = $json->allow_blessed($self->allow_blessed) if $self->has_allow_blessed;
      $json = $json->allow_unknown($self->allow_unknown) if $self->has_allow_unknown;
      $json = $json->pretty($self->pretty) if $self->has_pretty;
      return $json;
    },
  );
  
  has pretty => (
    is => 'ro',
    lazy => 1,
    predicate => 1,
  );
  
  has allow_unknown => (
    is => 'ro',
    lazy => 1,
    predicate => 1,
  );
  
  has allow_blessed => (
    is => 'ro',
    lazy => 1,
    predicate => 1,
  );
  
  has convert_blessed => (
    is => 'ro',
    lazy => 1,
    predicate => 1,
  );
  
  has filename => (
    is => 'ro',
    required => 1,
  );
  
  has abs_filename => (
    is => 'ro',
    lazy => 1,
    default => sub { file(shift->filename)->absolute },
  );
  
  has tied => (
    is => 'ro',
    required => 1,
  );
  
  sub BUILD {
    my ( $self ) = @_;
    $self->abs_filename;
  }
  
  sub data {
    my ( $self ) = @_;
    if (-f $self->abs_filename) {
      return $self->load_file;
    } else {
      if ($self->tied eq 'HASH') {
        return {};
      } elsif ($self->tied eq 'ARRAY') {
        return [];
      }
    }
  }
  
  sub add_data {
    my ( $self, $key, $value ) = @_;
    my $data = $self->data;
    if ($self->tied eq 'HASH') {
      $data->{$key} = $value;
    } elsif ($self->tied eq 'ARRAY') {
      $data->[$key] = $value;
    }
    $self->save_file($data);
  }
  
  sub remove_data {
    my ( $self, $key, $value ) = @_;
    my $data = $self->data;
    if ($self->tied eq 'HASH') {
      delete $data->{$key};
    } elsif ($self->tied eq 'ARRAY') {
      delete $data->[$key];
    }
    $self->save_file($data);
  }
  
  sub load_file {
    my ( $self ) = @_;
    local $/;
    open( my $fh, '<', $self->abs_filename );
    my $json_text = <$fh>;
    return $self->json->decode( $json_text );
  }
  
  sub save_file {
    my ( $self, $data ) = @_;
    local $/;
    open( my $fh, '>', $self->abs_filename );
    my $json_text = $self->json->encode( $data );
    print $fh $json_text;
    close($fh);
  }
  
  sub TIEHASH {shift->new(
    filename => shift,
    tied => 'HASH',
    @_,
  )}
  
  sub TIEARRAY {shift->new(
    filename => shift,
    tied => 'ARRAY',
    @_,
  )}
  
  sub FETCH {
    my ( $self, $key ) = @_;
    if ($self->tied eq 'HASH') {
      return $self->data->{$key};
    } elsif ($self->tied eq 'ARRAY') {
      return $self->data->[$key];
    }
  }
  
  sub STORE {
    my ( $self, $key, $value ) = @_;
    $self->add_data($key,$value);
  }
  
  sub FETCHSIZE {
    my ( $self ) = @_;
    return scalar @{$self->data};
  }
  
  sub PUSH {
    my ( $self, @values ) = @_;
    my @array = @{$self->data};
    push @array, @values;
    $self->save_file(\@array);
  }
  
  sub UNSHIFT {
    my ( $self, @values ) = @_;
    my @array = @{$self->data};
    unshift @array, @values;
    $self->save_file(\@array);
  }
  
  sub POP {
    my ( $self ) = @_;
    my @array = @{$self->data};
    my $value = pop @array;
    $self->save_file(\@array);
    return $value;
  }
  
  sub SHIFT {
    my ( $self ) = @_;
    my @array = @{$self->data};
    my $value = shift @array;
    $self->save_file(\@array);
    return $value;
  }
  
  sub SPLICE {
    my $self = shift;
    return splice(@{$self->data},@_);
  }
  
  sub DELETE {
    my ( $self, $key ) = @_;
    $self->remove_data($key)
  }
  
  sub EXISTS {
    my ( $self, $key ) = @_;
    if ($self->tied eq 'HASH') {
      return exists $self->data->{$key};
    } elsif ($self->tied eq 'ARRAY') {
      return exists $self->data->[$key];
    }
  }
  
  sub SCALAR {
    my ( $self ) = @_;
    return scalar %{$self->data};
  }
  
  sub CLEAR {
    my ( $self ) = @_;
    if ($self->tied eq 'HASH') {
      $self->save_file({});
    } elsif ($self->tied eq 'ARRAY') {
      $self->save_file([]);
    }
  }
  
  sub EXTEND {}
  sub STORESIZE {}
  
  sub FIRSTKEY {
    my ( $self ) = @_;
    if ($self->tied eq 'HASH') {
      my ( $first ) = sort { $a cmp $b } keys %{$self->data};
      return defined $first ? ($first) : ();
    } elsif ($self->tied eq 'ARRAY') {
      return scalar @{$self->data} ? (0) : ();
    }
  }
  
  sub NEXTKEY {
    my ( $self, $last ) = @_;
    if ($self->tied eq 'HASH') {
      my @sorted_keys = sort { $a cmp $b } keys %{$self->data};
      while (@sorted_keys) {
        my $key = shift @sorted_keys;
        if ($key eq $last) {
          if (@sorted_keys) {
            return (shift @sorted_keys);
          } else {
            return;
          }
        }
      }
    } elsif ($self->tied eq 'ARRAY') {
      my $last_index = (scalar @{$self->data}) - 1;
      if ($last < $last_index) {
        return $last+1;
      } else {
        return;
      }
    }
  }
  
  sub UNTIE {}
  sub DESTROY {}
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  JSON_File - Tie a hash or an array to a JSON
  
  =head1 VERSION
  
  version 0.003
  
  =head1 SYNOPSIS
  
    use JSON_File;
  
    tie( my %data, 'JSON_File', 'data.json' );
  
    $data{key} = "value"; # data directly stored in file
    print $data{key};     # data is always read from file, not cached
  
    tie( my @array, 'JSON_File', 'array.json' );
  
    push @array, "value";
  
    # you can enable functions of the JSON object:
  
    tie( my %other, 'JSON_File', 'other.json',
      pretty => 1,
      allow_unknown => 1,
      allow_blessed => 1,
      convert_blessed => 1,
    );
  
  =head1 DESCRIPTION
  
  This module is allowing you to bind a perl hash or array to a file. The data
  is always read directly from the file and also directly written to the file.
  This means also that if you add several keys to the hash or several elements
  to the array, that every key and every element will let the complete json file
  be rewritten.
  
  This is BETA, defaults may change in the future.
  
  =encoding utf8
  
  =head1 SUPPORT
  
  IRC
  
    Join #duckduckgo on FreeNode. Highlight Getty for fast reaction :).
  
  Repository
  
    http://github.com/Getty/p5-json_file
    Pull request and additional contributors are welcome
  
  Issue Tracker
  
    http://github.com/Getty/p5-json_file/issues
  
  =head1 AUTHOR
  
  Torsten Raudssus <torsten@raudss.us>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Torsten Raudssus.
  
  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
JSON_FILE

$fatpacked{"LWP.pm"} = <<'LWP';
  package LWP;
  
  $VERSION = "6.05";
  sub Version { $VERSION; }
  
  require 5.008;
  require LWP::UserAgent;  # this should load everything you need
  
  1;
  
  __END__
  
  =encoding utf-8
  
  =head1 NAME
  
  LWP - The World-Wide Web library for Perl
  
  =head1 SYNOPSIS
  
    use LWP;
    print "This is libwww-perl-$LWP::VERSION\n";
  
  
  =head1 DESCRIPTION
  
  The libwww-perl collection is a set of Perl modules which provides a
  simple and consistent application programming interface (API) to the
  World-Wide Web.  The main focus of the library is to provide classes
  and functions that allow you to write WWW clients. The library also
  contain modules that are of more general use and even classes that
  help you implement simple HTTP servers.
  
  Most modules in this library provide an object oriented API.  The user
  agent, requests sent and responses received from the WWW server are
  all represented by objects.  This makes a simple and powerful
  interface to these services.  The interface is easy to extend
  and customize for your own needs.
  
  The main features of the library are:
  
  =over 3
  
  =item *
  
  Contains various reusable components (modules) that can be
  used separately or together.
  
  =item *
  
  Provides an object oriented model of HTTP-style communication.  Within
  this framework we currently support access to http, https, gopher, ftp, news,
  file, and mailto resources.
  
  =item *
  
  Provides a full object oriented interface or
  a very simple procedural interface.
  
  =item *
  
  Supports the basic and digest authorization schemes.
  
  =item *
  
  Supports transparent redirect handling.
  
  =item *
  
  Supports access through proxy servers.
  
  =item *
  
  Provides parser for F<robots.txt> files and a framework for constructing robots.
  
  =item *
  
  Supports parsing of HTML forms.
  
  =item *
  
  Implements HTTP content negotiation algorithm that can
  be used both in protocol modules and in server scripts (like CGI
  scripts).
  
  =item *
  
  Supports HTTP cookies.
  
  =item *
  
  Some simple command line clients, for instance C<lwp-request> and C<lwp-download>.
  
  =back
  
  
  =head1 HTTP STYLE COMMUNICATION
  
  
  The libwww-perl library is based on HTTP style communication. This
  section tries to describe what that means.
  
  Let us start with this quote from the HTTP specification document
  <URL:http://www.w3.org/Protocols/>:
  
  =over 3
  
  =item
  
  The HTTP protocol is based on a request/response paradigm. A client
  establishes a connection with a server and sends a request to the
  server in the form of a request method, URI, and protocol version,
  followed by a MIME-like message containing request modifiers, client
  information, and possible body content. The server responds with a
  status line, including the message's protocol version and a success or
  error code, followed by a MIME-like message containing server
  information, entity meta-information, and possible body content.
  
  =back
  
  What this means to libwww-perl is that communication always take place
  through these steps: First a I<request> object is created and
  configured. This object is then passed to a server and we get a
  I<response> object in return that we can examine. A request is always
  independent of any previous requests, i.e. the service is stateless.
  The same simple model is used for any kind of service we want to
  access.
  
  For example, if we want to fetch a document from a remote file server,
  then we send it a request that contains a name for that document and
  the response will contain the document itself.  If we access a search
  engine, then the content of the request will contain the query
  parameters and the response will contain the query result.  If we want
  to send a mail message to somebody then we send a request object which
  contains our message to the mail server and the response object will
  contain an acknowledgment that tells us that the message has been
  accepted and will be forwarded to the recipient(s).
  
  It is as simple as that!
  
  
  =head2 The Request Object
  
  The libwww-perl request object has the class name C<HTTP::Request>.
  The fact that the class name uses C<HTTP::> as a
  prefix only implies that we use the HTTP model of communication.  It
  does not limit the kind of services we can try to pass this I<request>
  to.  For instance, we will send C<HTTP::Request>s both to ftp and
  gopher servers, as well as to the local file system.
  
  The main attributes of the request objects are:
  
  =over 3
  
  =item *
  
  B<method> is a short string that tells what kind of
  request this is.  The most common methods are B<GET>, B<PUT>,
  B<POST> and B<HEAD>.
  
  =item *
  
  B<uri> is a string denoting the protocol, server and
  the name of the "document" we want to access.  The B<uri> might
  also encode various other parameters.
  
  =item *
  
  B<headers> contains additional information about the
  request and can also used to describe the content.  The headers
  are a set of keyword/value pairs.
  
  =item *
  
  B<content> is an arbitrary amount of data.
  
  =back
  
  =head2 The Response Object
  
  The libwww-perl response object has the class name C<HTTP::Response>.
  The main attributes of objects of this class are:
  
  =over 3
  
  =item *
  
  B<code> is a numerical value that indicates the overall
  outcome of the request.
  
  =item *
  
  B<message> is a short, human readable string that
  corresponds to the I<code>.
  
  =item *
  
  B<headers> contains additional information about the
  response and describe the content.
  
  =item *
  
  B<content> is an arbitrary amount of data.
  
  =back
  
  Since we don't want to handle all possible I<code> values directly in
  our programs, a libwww-perl response object has methods that can be
  used to query what kind of response this is.  The most commonly used
  response classification methods are:
  
  =over 3
  
  =item is_success()
  
  The request was successfully received, understood or accepted.
  
  =item is_error()
  
  The request failed.  The server or the resource might not be
  available, access to the resource might be denied or other things might
  have failed for some reason.
  
  =back
  
  =head2 The User Agent
  
  Let us assume that we have created a I<request> object. What do we
  actually do with it in order to receive a I<response>?
  
  The answer is that you pass it to a I<user agent> object and this
  object takes care of all the things that need to be done
  (like low-level communication and error handling) and returns
  a I<response> object. The user agent represents your
  application on the network and provides you with an interface that
  can accept I<requests> and return I<responses>.
  
  The user agent is an interface layer between
  your application code and the network.  Through this interface you are
  able to access the various servers on the network.
  
  The class name for the user agent is C<LWP::UserAgent>.  Every
  libwww-perl application that wants to communicate should create at
  least one object of this class. The main method provided by this
  object is request(). This method takes an C<HTTP::Request> object as
  argument and (eventually) returns a C<HTTP::Response> object.
  
  The user agent has many other attributes that let you
  configure how it will interact with the network and with your
  application.
  
  =over 3
  
  =item *
  
  B<timeout> specifies how much time we give remote servers to
  respond before the library disconnects and creates an
  internal I<timeout> response.
  
  =item *
  
  B<agent> specifies the name that your application uses when it
  presents itself on the network.
  
  =item *
  
  B<from> can be set to the e-mail address of the person
  responsible for running the application.  If this is set, then the
  address will be sent to the servers with every request.
  
  =item *
  
  B<parse_head> specifies whether we should initialize response
  headers from the E<lt>head> section of HTML documents.
  
  =item *
  
  B<proxy> and B<no_proxy> specify if and when to go through
  a proxy server. <URL:http://www.w3.org/History/1994/WWW/Proxies/>
  
  =item *
  
  B<credentials> provides a way to set up user names and
  passwords needed to access certain services.
  
  =back
  
  Many applications want even more control over how they interact
  with the network and they get this by sub-classing
  C<LWP::UserAgent>.  The library includes a
  sub-class, C<LWP::RobotUA>, for robot applications.
  
  =head2 An Example
  
  This example shows how the user agent, a request and a response are
  represented in actual perl code:
  
    # Create a user agent object
    use LWP::UserAgent;
    my $ua = LWP::UserAgent->new;
    $ua->agent("MyApp/0.1 ");
  
    # Create a request
    my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search');
    $req->content_type('application/x-www-form-urlencoded');
    $req->content('query=libwww-perl&mode=dist');
  
    # Pass request to the user agent and get a response back
    my $res = $ua->request($req);
  
    # Check the outcome of the response
    if ($res->is_success) {
        print $res->content;
    }
    else {
        print $res->status_line, "\n";
    }
  
  The $ua is created once when the application starts up.  New request
  objects should normally created for each request sent.
  
  
  =head1 NETWORK SUPPORT
  
  This section discusses the various protocol schemes and
  the HTTP style methods that headers may be used for each.
  
  For all requests, a "User-Agent" header is added and initialized from
  the $ua->agent attribute before the request is handed to the network
  layer.  In the same way, a "From" header is initialized from the
  $ua->from attribute.
  
  For all responses, the library adds a header called "Client-Date".
  This header holds the time when the response was received by
  your application.  The format and semantics of the header are the
  same as the server created "Date" header.  You may also encounter other
  "Client-XXX" headers.  They are all generated by the library
  internally and are not received from the servers.
  
  =head2 HTTP Requests
  
  HTTP requests are just handed off to an HTTP server and it
  decides what happens.  Few servers implement methods beside the usual
  "GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement
  any method they like.
  
  If the server is not available then the library will generate an
  internal error response.
  
  The library automatically adds a "Host" and a "Content-Length" header
  to the HTTP request before it is sent over the network.
  
  For a GET request you might want to add a "If-Modified-Since" or
  "If-None-Match" header to make the request conditional.
  
  For a POST request you should add the "Content-Type" header.  When you
  try to emulate HTML E<lt>FORM> handling you should usually let the value
  of the "Content-Type" header be "application/x-www-form-urlencoded".
  See L<lwpcook> for examples of this.
  
  The libwww-perl HTTP implementation currently support the HTTP/1.1
  and HTTP/1.0 protocol.
  
  The library allows you to access proxy server through HTTP.  This
  means that you can set up the library to forward all types of request
  through the HTTP protocol module.  See L<LWP::UserAgent> for
  documentation of this.
  
  
  =head2 HTTPS Requests
  
  HTTPS requests are HTTP requests over an encrypted network connection
  using the SSL protocol developed by Netscape.  Everything about HTTP
  requests above also apply to HTTPS requests.  In addition the library
  will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and
  "Client-SSL-Cert-Issuer" to the response.  These headers denote the
  encryption method used and the name of the server owner.
  
  The request can contain the header "If-SSL-Cert-Subject" in order to
  make the request conditional on the content of the server certificate.
  If the certificate subject does not match, no request is sent to the
  server and an internally generated error response is returned.  The
  value of the "If-SSL-Cert-Subject" header is interpreted as a Perl
  regular expression.
  
  
  =head2 FTP Requests
  
  The library currently supports GET, HEAD and PUT requests.  GET
  retrieves a file or a directory listing from an FTP server.  PUT
  stores a file on a ftp server.
  
  You can specify a ftp account for servers that want this in addition
  to user name and password.  This is specified by including an "Account"
  header in the request.
  
  User name/password can be specified using basic authorization or be
  encoded in the URL.  Failed logins return an UNAUTHORIZED response with
  "WWW-Authenticate: Basic" and can be treated like basic authorization
  for HTTP.
  
  The library supports ftp ASCII transfer mode by specifying the "type=a"
  parameter in the URL. It also supports transfer of ranges for FTP transfers
  using the "Range" header.
  
  Directory listings are by default returned unprocessed (as returned
  from the ftp server) with the content media type reported to be
  "text/ftp-dir-listing". The C<File::Listing> module provides methods
  for parsing of these directory listing.
  
  The ftp module is also able to convert directory listings to HTML and
  this can be requested via the standard HTTP content negotiation
  mechanisms (add an "Accept: text/html" header in the request if you
  want this).
  
  For normal file retrievals, the "Content-Type" is guessed based on the
  file name suffix. See L<LWP::MediaTypes>.
  
  The "If-Modified-Since" request header works for servers that implement
  the MDTM command.  It will probably not work for directory listings though.
  
  Example:
  
    $req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/');
    $req->header(Accept => "text/html, */*;q=0.1");
  
  =head2 News Requests
  
  Access to the USENET News system is implemented through the NNTP
  protocol.  The name of the news server is obtained from the
  NNTP_SERVER environment variable and defaults to "news".  It is not
  possible to specify the hostname of the NNTP server in news: URLs.
  
  The library supports GET and HEAD to retrieve news articles through the
  NNTP protocol.  You can also post articles to newsgroups by using
  (surprise!) the POST method.
  
  GET on newsgroups is not implemented yet.
  
  Examples:
  
    $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no');
  
    $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test');
    $req->header(Subject => 'This is a test',
                 From    => 'me@some.where.org');
    $req->content(<<EOT);
    This is the content of the message that we are sending to
    the world.
    EOT
  
  
  =head2 Gopher Request
  
  The library supports the GET and HEAD methods for gopher requests.  All
  request header values are ignored.  HEAD cheats and returns a
  response without even talking to server.
  
  Gopher menus are always converted to HTML.
  
  The response "Content-Type" is generated from the document type
  encoded (as the first letter) in the request URL path itself.
  
  Example:
  
    $req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/');
  
  
  
  =head2 File Request
  
  The library supports GET and HEAD methods for file requests.  The
  "If-Modified-Since" header is supported.  All other headers are
  ignored.  The I<host> component of the file URL must be empty or set
  to "localhost".  Any other I<host> value will be treated as an error.
  
  Directories are always converted to an HTML document.  For normal
  files, the "Content-Type" and "Content-Encoding" in the response are
  guessed based on the file suffix.
  
  Example:
  
    $req = HTTP::Request->new(GET => 'file:/etc/passwd');
  
  
  =head2 Mailto Request
  
  You can send (aka "POST") mail messages using the library.  All
  headers specified for the request are passed on to the mail system.
  The "To" header is initialized from the mail address in the URL.
  
  Example:
  
    $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org');
    $req->header(Subject => "subscribe");
    $req->content("Please subscribe me to the libwww-perl mailing list!\n");
  
  =head2 CPAN Requests
  
  URLs with scheme C<cpan:> are redirected to the a suitable CPAN
  mirror.  If you have your own local mirror of CPAN you might tell LWP
  to use it for C<cpan:> URLs by an assignment like this:
  
    $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/";
  
  Suitable CPAN mirrors are also picked up from the configuration for
  the CPAN.pm, so if you have used that module a suitable mirror should
  be picked automatically.  If neither of these apply, then a redirect
  to the generic CPAN http location is issued.
  
  Example request to download the newest perl:
  
    $req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz");
  
  
  =head1 OVERVIEW OF CLASSES AND PACKAGES
  
  This table should give you a quick overview of the classes provided by the
  library. Indentation shows class inheritance.
  
   LWP::MemberMixin   -- Access to member variables of Perl5 classes
     LWP::UserAgent   -- WWW user agent class
       LWP::RobotUA   -- When developing a robot applications
     LWP::Protocol          -- Interface to various protocol schemes
       LWP::Protocol::http  -- http:// access
       LWP::Protocol::file  -- file:// access
       LWP::Protocol::ftp   -- ftp:// access
       ...
  
   LWP::Authen::Basic -- Handle 401 and 407 responses
   LWP::Authen::Digest
  
   HTTP::Headers      -- MIME/RFC822 style header (used by HTTP::Message)
   HTTP::Message      -- HTTP style message
     HTTP::Request    -- HTTP request
     HTTP::Response   -- HTTP response
   HTTP::Daemon       -- A HTTP server class
  
   WWW::RobotRules    -- Parse robots.txt files
     WWW::RobotRules::AnyDBM_File -- Persistent RobotRules
  
   Net::HTTP          -- Low level HTTP client
  
  The following modules provide various functions and definitions.
  
   LWP                -- This file.  Library version number and documentation.
   LWP::MediaTypes    -- MIME types configuration (text/html etc.)
   LWP::Simple        -- Simplified procedural interface for common functions
   HTTP::Status       -- HTTP status code (200 OK etc)
   HTTP::Date         -- Date parsing module for HTTP date formats
   HTTP::Negotiate    -- HTTP content negotiation calculation
   File::Listing      -- Parse directory listings
   HTML::Form         -- Processing for <form>s in HTML documents
  
  
  =head1 MORE DOCUMENTATION
  
  All modules contain detailed information on the interfaces they
  provide.  The L<lwpcook> manpage is the libwww-perl cookbook that contain
  examples of typical usage of the library.  You might want to take a
  look at how the scripts L<lwp-request>, L<lwp-download>, L<lwp-dump>
  and L<lwp-mirror> are implemented.
  
  =head1 ENVIRONMENT
  
  The following environment variables are used by LWP:
  
  =over
  
  =item HOME
  
  The C<LWP::MediaTypes> functions will look for the F<.media.types> and
  F<.mime.types> files relative to you home directory.
  
  =item http_proxy
  
  =item ftp_proxy
  
  =item xxx_proxy
  
  =item no_proxy
  
  These environment variables can be set to enable communication through
  a proxy server.  See the description of the C<env_proxy> method in
  L<LWP::UserAgent>.
  
  =item PERL_LWP_ENV_PROXY
  
  If set to a TRUE value, then the C<LWP::UserAgent> will by default call
  C<env_proxy> during initialization.  This makes LWP honor the proxy variables
  described above.
  
  =item PERL_LWP_SSL_VERIFY_HOSTNAME
  
  The default C<verify_hostname> setting for C<LWP::UserAgent>.  If
  not set the default will be 1.  Set it as 0 to disable hostname
  verification (the default prior to libwww-perl 5.840.
  
  =item PERL_LWP_SSL_CA_FILE
  
  =item PERL_LWP_SSL_CA_PATH
  
  The file and/or directory
  where the trusted Certificate Authority certificates
  is located.  See L<LWP::UserAgent> for details.
  
  =item PERL_HTTP_URI_CLASS
  
  Used to decide what URI objects to instantiate.  The default is C<URI>.
  You might want to set it to C<URI::URL> for compatibility with old times.
  
  =back
  
  =head1 AUTHORS
  
  LWP was made possible by contributions from Adam Newby, Albert
  Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas König,
  Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben
  Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian
  J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor,
  Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan
  Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David
  D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas,
  Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry
  Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack
  Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao
  Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua
  Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken
  Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund,
  Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg,
  Markus B Krüger, Markus Laker, Martijn Koster, Martin Thurn, Matthew
  Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael
  Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan
  Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul
  J. Schinder, peterm, Philip GuentherDaniel Buenzli, Pon Hwa Lin,
  Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen,
  Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke,
  shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler,
  Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes,
  Tony Finch, Ville Skyttä, Ward Vandewege, William York, Yale Huang,
  and Yitzchak Scott-Thoennes.
  
  LWP owes a lot in motivation, design, and code, to the libwww-perl
  library for Perl4 by Roy Fielding, which included work from Alberto
  Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar
  Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack
  Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion
  Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the
  libwww-perl-0.40 library for details.
  
  =head1 COPYRIGHT
  
    Copyright 1995-2009, Gisle Aas
    Copyright 1995, Martijn Koster
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =head1 AVAILABILITY
  
  The latest version of this library is likely to be available from CPAN
  as well as:
  
    http://github.com/libwww-perl/libwww-perl
  
  The best place to discuss this code is on the <libwww@perl.org>
  mailing list.
  
  =cut
LWP

$fatpacked{"LWP/Authen/Basic.pm"} = <<'LWP_AUTHEN_BASIC';
  package LWP::Authen::Basic;
  use strict;
  
  require MIME::Base64;
  
  sub auth_header {
      my($class, $user, $pass) = @_;
      return "Basic " . MIME::Base64::encode("$user:$pass", "");
  }
  
  sub authenticate
  {
      my($class, $ua, $proxy, $auth_param, $response,
         $request, $arg, $size) = @_;
  
      my $realm = $auth_param->{realm} || "";
      my $url = $proxy ? $request->{proxy} : $request->uri_canonical;
      return $response unless $url;
      my $host_port = $url->host_port;
      my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
  
      my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port);
      push(@m, realm => $realm);
  
      my $h = $ua->get_my_handler("request_prepare", @m, sub {
          $_[0]{callback} = sub {
              my($req, $ua, $h) = @_;
              my($user, $pass) = $ua->credentials($host_port, $h->{realm});
  	    if (defined $user) {
  		my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h);
  		$req->header($auth_header => $auth_value);
  	    }
          };
      });
      $h->{auth_param} = $auth_param;
  
      if (!$proxy && !$request->header($auth_header) && $ua->credentials($host_port, $realm)) {
  	# we can make sure this handler applies and retry
          add_path($h, $url->path);
          return $ua->request($request->clone, $arg, $size, $response);
      }
  
      my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy);
      unless (defined $user and defined $pass) {
  	$ua->set_my_handler("request_prepare", undef, @m);  # delete handler
  	return $response;
      }
  
      # check that the password has changed
      my ($olduser, $oldpass) = $ua->credentials($host_port, $realm);
      return $response if (defined $olduser and defined $oldpass and
                           $user eq $olduser and $pass eq $oldpass);
  
      $ua->credentials($host_port, $realm, $user, $pass);
      add_path($h, $url->path) unless $proxy;
      return $ua->request($request->clone, $arg, $size, $response);
  }
  
  sub add_path {
      my($h, $path) = @_;
      $path =~ s,[^/]+\z,,;
      push(@{$h->{m_path_prefix}}, $path);
  }
  
  1;
LWP_AUTHEN_BASIC

$fatpacked{"LWP/Authen/Digest.pm"} = <<'LWP_AUTHEN_DIGEST';
  package LWP::Authen::Digest;
  
  use strict;
  use base 'LWP::Authen::Basic';
  
  require Digest::MD5;
  
  sub auth_header {
      my($class, $user, $pass, $request, $ua, $h) = @_;
  
      my $auth_param = $h->{auth_param};
  
      my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}};
      my $cnonce = sprintf "%8x", time;
  
      my $uri = $request->uri->path_query;
      $uri = "/" unless length $uri;
  
      my $md5 = Digest::MD5->new;
  
      my(@digest);
      $md5->add(join(":", $user, $auth_param->{realm}, $pass));
      push(@digest, $md5->hexdigest);
      $md5->reset;
  
      push(@digest, $auth_param->{nonce});
  
      if ($auth_param->{qop}) {
  	push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
      }
  
      $md5->add(join(":", $request->method, $uri));
      push(@digest, $md5->hexdigest);
      $md5->reset;
  
      $md5->add(join(":", @digest));
      my($digest) = $md5->hexdigest;
      $md5->reset;
  
      my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
      @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");
  
      if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
  	@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
      }
  
      my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response);
      if($request->method =~ /^(?:POST|PUT)$/) {
  	$md5->add($request->content);
  	my $content = $md5->hexdigest;
  	$md5->reset;
  	$md5->add(join(":", @digest[0..1], $content));
  	$md5->reset;
  	$resp{"message-digest"} = $md5->hexdigest;
  	push(@order, "message-digest");
      }
      push(@order, "opaque");
      my @pairs;
      for (@order) {
  	next unless defined $resp{$_};
  	push(@pairs, "$_=" . qq("$resp{$_}"));
      }
  
      my $auth_value  = "Digest " . join(", ", @pairs);
      return $auth_value;
  }
  
  1;
LWP_AUTHEN_DIGEST

$fatpacked{"LWP/Authen/Ntlm.pm"} = <<'LWP_AUTHEN_NTLM';
  package LWP::Authen::Ntlm;
  
  use strict;
  use vars qw/$VERSION/;
  
  $VERSION = "6.00";
  
  use Authen::NTLM "1.02";
  use MIME::Base64 "2.12";
  
  sub authenticate {
      my($class, $ua, $proxy, $auth_param, $response,
         $request, $arg, $size) = @_;
  
      my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
                                                    $request->uri, $proxy);
  
      unless(defined $user and defined $pass) {
  		return $response;
  	}
  
  	if (!$ua->conn_cache()) {
  		warn "The keep_alive option must be enabled for NTLM authentication to work.  NTLM authentication aborted.\n";
  		return $response;
  	}
  
  	my($domain, $username) = split(/\\/, $user);
  
  	ntlm_domain($domain);
  	ntlm_user($username);
  	ntlm_password($pass);
  
      my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
  
  	# my ($challenge) = $response->header('WWW-Authenticate'); 
  	my $challenge;
  	foreach ($response->header('WWW-Authenticate')) { 
  		last if /^NTLM/ && ($challenge=$_);
  	}
  
  	if ($challenge eq 'NTLM') {
  		# First phase, send handshake
  	    my $auth_value = "NTLM " . ntlm();
  		ntlm_reset();
  
  	    # Need to check this isn't a repeated fail!
  	    my $r = $response;
  		my $retry_count = 0;
  	    while ($r) {
  			my $auth = $r->request->header($auth_header);
  			++$retry_count if ($auth && $auth eq $auth_value);
  			if ($retry_count > 2) {
  				    # here we know this failed before
  				    $response->header("Client-Warning" =>
  						      "Credentials for '$user' failed before");
  				    return $response;
  			}
  			$r = $r->previous;
  	    }
  
  	    my $referral = $request->clone;
  	    $referral->header($auth_header => $auth_value);
  	    return $ua->request($referral, $arg, $size, $response);
  	}
  	
  	else {
  		# Second phase, use the response challenge (unless non-401 code
  		#  was returned, in which case, we just send back the response
  		#  object, as is
  		my $auth_value;
  		if ($response->code ne '401') {
  			return $response;
  		}
  		else {
  			my $challenge;
  			foreach ($response->header('WWW-Authenticate')) { 
  				last if /^NTLM/ && ($challenge=$_);
  			}
  			$challenge =~ s/^NTLM //;
  			ntlm();
  			$auth_value = "NTLM " . ntlm($challenge);
  			ntlm_reset();
  		}
  
  	    my $referral = $request->clone;
  	    $referral->header($auth_header => $auth_value);
  	    my $response2 = $ua->request($referral, $arg, $size, $response);
  		return $response2;
  	}
  }
  
  1;
  
  
  =head1 NAME
  
  LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP
  
  =head1 SYNOPSIS
  
   use LWP::UserAgent;
   use HTTP::Request::Common;
   my $url = 'http://www.company.com/protected_page.html';
  
   # Set up the ntlm client and then the base64 encoded ntlm handshake message
   my $ua = LWP::UserAgent->new(keep_alive=>1);
   $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
  
   $request = GET $url;
   print "--Performing request now...-----------\n";
   $response = $ua->request($request);
   print "--Done with request-------------------\n";
  
   if ($response->is_success) {print "It worked!->" . $response->code . "\n"}
   else {print "It didn't work!->" . $response->code . "\n"}
  
  =head1 DESCRIPTION
  
  C<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the 
  NTLM authentication scheme popularized by Microsoft.  This type of authentication is 
  common on intranets of Microsoft-centric organizations.
  
  The module takes advantage of the Authen::NTLM module by Mark Bush.  Since there 
  is also another Authen::NTLM module available from CPAN by Yee Man Chan with an 
  entirely different interface, it is necessary to ensure that you have the correct 
  NTLM module.
  
  In addition, there have been problems with incompatibilities between different 
  versions of Mime::Base64, which Bush's Authen::NTLM makes use of.  Therefore, it is 
  necessary to ensure that your Mime::Base64 module supports exporting of the 
  encode_base64 and decode_base64 functions.
  
  =head1 USAGE
  
  The module is used indirectly through LWP, rather than including it directly in your 
  code.  The LWP system will invoke the NTLM authentication when it encounters the 
  authentication scheme while attempting to retrieve a URL from a server.  In order 
  for the NTLM authentication to work, you must have a few things set up in your 
  code prior to attempting to retrieve the URL:
  
  =over 4
  
  =item *
  
  Enable persistent HTTP connections
  
  To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this:
  
      my $ua = LWP::UserAgent->new(keep_alive=>1);
  
  =item *
  
  Set the credentials on the UserAgent object
  
  The credentials must be set like this:
  
     $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
  
  Note that you cannot use the HTTP::Request object's authorization_basic() method to set 
  the credentials.  Note, too, that the 'www.company.com:80' portion only sets credentials 
  on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and 
  has nothing to do with LWP::Authen::Ntlm)
  
  =back
  
  =head1 AVAILABILITY
  
  General queries regarding LWP should be made to the LWP Mailing List.
  
  Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com
  
  =head1 COPYRIGHT
  
  Copyright (c) 2002 James Tillman. All rights reserved. This
  program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<LWP>, L<LWP::UserAgent>, L<lwpcook>.
LWP_AUTHEN_NTLM

$fatpacked{"LWP/ConnCache.pm"} = <<'LWP_CONNCACHE';
  package LWP::ConnCache;
  
  use strict;
  use vars qw($VERSION $DEBUG);
  
  $VERSION = "6.02";
  
  
  sub new {
      my($class, %cnf) = @_;
  
      my $total_capacity = 1;
      if (exists $cnf{total_capacity}) {
          $total_capacity = delete $cnf{total_capacity};
      }
      if (%cnf && $^W) {
  	require Carp;
  	Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
      }
      my $self = bless { cc_conns => [] }, $class;
      $self->total_capacity($total_capacity);
      $self;
  }
  
  
  sub deposit {
      my($self, $type, $key, $conn) = @_;
      push(@{$self->{cc_conns}}, [$conn, $type, $key, time]);
      $self->enforce_limits($type);
      return;
  }
  
  
  sub withdraw {
      my($self, $type, $key) = @_;
      my $conns = $self->{cc_conns};
      for my $i (0 .. @$conns - 1) {
  	my $c = $conns->[$i];
  	next unless $c->[1] eq $type && $c->[2] eq $key;
  	splice(@$conns, $i, 1);  # remove it
  	return $c->[0];
      }
      return undef;
  }
  
  
  sub total_capacity {
      my $self = shift;
      my $old = $self->{cc_limit_total};
      if (@_) {
  	$self->{cc_limit_total} = shift;
  	$self->enforce_limits;
      }
      $old;
  }
  
  
  sub capacity {
      my $self = shift;
      my $type = shift;
      my $old = $self->{cc_limit}{$type};
      if (@_) {
  	$self->{cc_limit}{$type} = shift;
  	$self->enforce_limits($type);
      }
      $old;
  }
  
  
  sub enforce_limits {
      my($self, $type) = @_;
      my $conns = $self->{cc_conns};
  
      my @types = $type ? ($type) : ($self->get_types);
      for $type (@types) {
  	next unless $self->{cc_limit};
  	my $limit = $self->{cc_limit}{$type};
  	next unless defined $limit;
  	for my $i (reverse 0 .. @$conns - 1) {
  	    next unless $conns->[$i][1] eq $type;
  	    if (--$limit < 0) {
  		$self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded");
  	    }
  	}
      }
  
      if (defined(my $total = $self->{cc_limit_total})) {
  	while (@$conns > $total) {
  	    $self->dropping(shift(@$conns), "Total capacity exceeded");
  	}
      }
  }
  
  
  sub dropping {
      my($self, $c, $reason) = @_;
      print "DROPPING @$c [$reason]\n" if $DEBUG;
  }
  
  
  sub drop {
      my($self, $checker, $reason) = @_;
      if (ref($checker) ne "CODE") {
  	# make it so
  	if (!defined $checker) {
  	    $checker = sub { 1 };  # drop all of them
  	}
  	elsif (_looks_like_number($checker)) {
  	    my $age_limit = $checker;
  	    my $time_limit = time - $age_limit;
  	    $reason ||= "older than $age_limit";
  	    $checker = sub { $_[3] < $time_limit };
  	}
  	else {
  	    my $type = $checker;
  	    $reason ||= "drop $type";
  	    $checker = sub { $_[1] eq $type };  # match on type
  	}
      }
      $reason ||= "drop";
  
      local $SIG{__DIE__};  # don't interfere with eval below
      local $@;
      my @c;
      for (@{$self->{cc_conns}}) {
  	my $drop;
  	eval {
  	    if (&$checker(@$_)) {
  		$self->dropping($_, $reason);
  		$drop++;
  	    }
  	};
  	push(@c, $_) unless $drop;
      }
      @{$self->{cc_conns}} = @c;
  }
  
  
  sub prune {
      my $self = shift;
      $self->drop(sub { !shift->ping }, "ping");
  }
  
  
  sub get_types {
      my $self = shift;
      my %t;
      $t{$_->[1]}++ for @{$self->{cc_conns}};
      return keys %t;
  }
  
  
  sub get_connections {
      my($self, $type) = @_;
      my @c;
      for (@{$self->{cc_conns}}) {
  	push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]);
      }
      @c;
  }
  
  
  sub _looks_like_number {
      $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
  }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  LWP::ConnCache - Connection cache manager
  
  =head1 NOTE
  
  This module is experimental.  Details of its interface is likely to
  change in the future.
  
  =head1 SYNOPSIS
  
   use LWP::ConnCache;
   my $cache = LWP::ConnCache->new;
   $cache->deposit($type, $key, $sock);
   $sock = $cache->withdraw($type, $key);
  
  =head1 DESCRIPTION
  
  The C<LWP::ConnCache> class is the standard connection cache manager
  for LWP::UserAgent.
  
  The following basic methods are provided:
  
  =over
  
  =item $cache = LWP::ConnCache->new( %options )
  
  This method constructs a new C<LWP::ConnCache> object.  The only
  option currently accepted is 'total_capacity'.  If specified it
  initialize the total_capacity option.  It defaults to the value 1.
  
  =item $cache->total_capacity( [$num_connections] )
  
  Get/sets the number of connection that will be cached.  Connections
  will start to be dropped when this limit is reached.  If set to C<0>,
  then all connections are immediately dropped.  If set to C<undef>,
  then there is no limit.
  
  =item $cache->capacity($type, [$num_connections] )
  
  Get/set a limit for the number of connections of the specified type
  that can be cached.  The $type will typically be a short string like
  "http" or "ftp".
  
  =item $cache->drop( [$checker, [$reason]] )
  
  Drop connections by some criteria.  The $checker argument is a
  subroutine that is called for each connection.  If the routine returns
  a TRUE value then the connection is dropped.  The routine is called
  with ($conn, $type, $key, $deposit_time) as arguments.
  
  Shortcuts: If the $checker argument is absent (or C<undef>) all cached
  connections are dropped.  If the $checker is a number then all
  connections untouched that the given number of seconds or more are
  dropped.  If $checker is a string then all connections of the given
  type are dropped.
  
  The $reason argument is passed on to the dropped() method.
  
  =item $cache->prune
  
  Calling this method will drop all connections that are dead.  This is
  tested by calling the ping() method on the connections.  If the ping()
  method exists and returns a FALSE value, then the connection is
  dropped.
  
  =item $cache->get_types
  
  This returns all the 'type' fields used for the currently cached
  connections.
  
  =item $cache->get_connections( [$type] )
  
  This returns all connection objects of the specified type.  If no type
  is specified then all connections are returned.  In scalar context the
  number of cached connections of the specified type is returned.
  
  =back
  
  
  The following methods are called by low-level protocol modules to
  try to save away connections and to get them back.
  
  =over
  
  =item $cache->deposit($type, $key, $conn)
  
  This method adds a new connection to the cache.  As a result other
  already cached connections might be dropped.  Multiple connections with
  the same $type/$key might added.
  
  =item $conn = $cache->withdraw($type, $key)
  
  This method tries to fetch back a connection that was previously
  deposited.  If no cached connection with the specified $type/$key is
  found, then C<undef> is returned.  There is not guarantee that a
  deposited connection can be withdrawn, as the cache manger is free to
  drop connections at any time.
  
  =back
  
  The following methods are called internally.  Subclasses might want to
  override them.
  
  =over
  
  =item $conn->enforce_limits([$type])
  
  This method is called with after a new connection is added (deposited)
  in the cache or capacity limits are adjusted.  The default
  implementation drops connections until the specified capacity limits
  are not exceeded.
  
  =item $conn->dropping($conn_record, $reason)
  
  This method is called when a connection is dropped.  The record
  belonging to the dropped connection is passed as the first argument
  and a string describing the reason for the drop is passed as the
  second argument.  The default implementation makes some noise if the
  $LWP::ConnCache::DEBUG variable is set and nothing more.
  
  =back
  
  =head1 SUBCLASSING
  
  For specialized cache policy it makes sense to subclass
  C<LWP::ConnCache> and perhaps override the deposit(), enforce_limits()
  and dropping() methods.
  
  The object itself is a hash.  Keys prefixed with C<cc_> are reserved
  for the base class.
  
  =head1 SEE ALSO
  
  L<LWP::UserAgent>
  
  =head1 COPYRIGHT
  
  Copyright 2001 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
LWP_CONNCACHE

$fatpacked{"LWP/Debug.pm"} = <<'LWP_DEBUG';
  package LWP::Debug;  # legacy
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(level trace debug conns);
  
  use Carp ();
  
  my @levels = qw(trace debug conns);
  %current_level = ();
  
  
  sub import
  {
      my $pack = shift;
      my $callpkg = caller(0);
      my @symbols = ();
      my @levels = ();
      for (@_) {
  	if (/^[-+]/) {
  	    push(@levels, $_);
  	}
  	else {
  	    push(@symbols, $_);
  	}
      }
      Exporter::export($pack, $callpkg, @symbols);
      level(@levels);
  }
  
  
  sub level
  {
      for (@_) {
  	if ($_ eq '+') {              # all on
  	    # switch on all levels
  	    %current_level = map { $_ => 1 } @levels;
  	}
  	elsif ($_ eq '-') {           # all off
  	    %current_level = ();
  	}
  	elsif (/^([-+])(\w+)$/) {
  	    $current_level{$2} = $1 eq '+';
  	}
  	else {
  	    Carp::croak("Illegal level format $_");
  	}
      }
  }
  
  
  sub trace  { _log(@_) if $current_level{'trace'}; }
  sub debug  { _log(@_) if $current_level{'debug'}; }
  sub conns  { _log(@_) if $current_level{'conns'}; }
  
  
  sub _log
  {
      my $msg = shift;
      $msg .= "\n" unless $msg =~ /\n$/;  # ensure trailing "\n"
  
      my($package,$filename,$line,$sub) = caller(2);
      print STDERR "$sub: $msg";
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  LWP::Debug - deprecated
  
  =head1 DESCRIPTION
  
  LWP::Debug used to provide tracing facilities, but these are not used
  by LWP any more.  The code in this module is kept around
  (undocumented) so that 3rd party code that happen to use the old
  interfaces continue to run.
  
  One useful feature that LWP::Debug provided (in an imprecise and
  troublesome way) was network traffic monitoring.  The following
  section provide some hints about recommened replacements.
  
  =head2 Network traffic monitoring
  
  The best way to monitor the network traffic that LWP generates is to
  use an external TCP monitoring program.  The Wireshark program
  (L<http://www.wireshark.org/>) is higly recommended for this.
  
  Another approach it to use a debugging HTTP proxy server and make
  LWP direct all its traffic via this one.  Call C<< $ua->proxy >> to
  set it up and then just use LWP as before.
  
  For less precise monitoring needs just setting up a few simple
  handlers might do.  The following example sets up handlers to dump the
  request and response objects that pass through LWP:
  
    use LWP::UserAgent;
    $ua = LWP::UserAgent->new;
    $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
  
    $ua->add_handler("request_send",  sub { shift->dump; return });
    $ua->add_handler("response_done", sub { shift->dump; return });
  
    $ua->get("http://www.example.com");
  
  =head1 SEE ALSO
  
  L<LWP::UserAgent>
LWP_DEBUG

$fatpacked{"LWP/DebugFile.pm"} = <<'LWP_DEBUGFILE';
  package LWP::DebugFile;
  
  # legacy stub
  
  1;
LWP_DEBUGFILE

$fatpacked{"LWP/MemberMixin.pm"} = <<'LWP_MEMBERMIXIN';
  package LWP::MemberMixin;
  
  sub _elem
  {
      my $self = shift;
      my $elem = shift;
      my $old = $self->{$elem};
      $self->{$elem} = shift if @_;
      return $old;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  LWP::MemberMixin - Member access mixin class
  
  =head1 SYNOPSIS
  
   package Foo;
   require LWP::MemberMixin;
   @ISA=qw(LWP::MemberMixin);
  
  =head1 DESCRIPTION
  
  A mixin class to get methods that provide easy access to member
  variables in the %$self.
  Ideally there should be better Perl language support for this.
  
  There is only one method provided:
  
  =over 4
  
  =item _elem($elem [, $val])
  
  Internal method to get/set the value of member variable
  C<$elem>. If C<$val> is present it is used as the new value
  for the member variable.  If it is not present the current
  value is not touched. In both cases the previous value of
  the member variable is returned.
  
  =back
LWP_MEMBERMIXIN

$fatpacked{"LWP/Protocol.pm"} = <<'LWP_PROTOCOL';
  package LWP::Protocol;
  
  require LWP::MemberMixin;
  @ISA = qw(LWP::MemberMixin);
  $VERSION = "6.00";
  
  use strict;
  use Carp ();
  use HTTP::Status ();
  use HTTP::Response;
  
  my %ImplementedBy = (); # scheme => classname
  
  
  
  sub new
  {
      my($class, $scheme, $ua) = @_;
  
      my $self = bless {
  	scheme => $scheme,
  	ua => $ua,
  
  	# historical/redundant
          max_size => $ua->{max_size},
      }, $class;
  
      $self;
  }
  
  
  sub create
  {
      my($scheme, $ua) = @_;
      my $impclass = LWP::Protocol::implementor($scheme) or
  	Carp::croak("Protocol scheme '$scheme' is not supported");
  
      # hand-off to scheme specific implementation sub-class
      my $protocol = $impclass->new($scheme, $ua);
  
      return $protocol;
  }
  
  
  sub implementor
  {
      my($scheme, $impclass) = @_;
  
      if ($impclass) {
  	$ImplementedBy{$scheme} = $impclass;
      }
      my $ic = $ImplementedBy{$scheme};
      return $ic if $ic;
  
      return '' unless $scheme =~ /^([.+\-\w]+)$/;  # check valid URL schemes
      $scheme = $1; # untaint
      $scheme =~ s/[.+\-]/_/g;  # make it a legal module name
  
      # scheme not yet known, look for a 'use'd implementation
      $ic = "LWP::Protocol::$scheme";  # default location
      $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
      no strict 'refs';
      # check we actually have one for the scheme:
      unless (@{"${ic}::ISA"}) {
  	# try to autoload it
  	eval "require $ic";
  	if ($@) {
  	    if ($@ =~ /Can't locate/) { #' #emacs get confused by '
  		$ic = '';
  	    }
  	    else {
  		die "$@\n";
  	    }
  	}
      }
      $ImplementedBy{$scheme} = $ic if $ic;
      $ic;
  }
  
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
      Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
  }
  
  
  # legacy
  sub timeout    { shift->_elem('timeout',    @_); }
  sub max_size   { shift->_elem('max_size',   @_); }
  
  
  sub collect
  {
      my ($self, $arg, $response, $collector) = @_;
      my $content;
      my($ua, $max_size) = @{$self}{qw(ua max_size)};
  
      eval {
  	local $\; # protect the print below from surprises
          if (!defined($arg) || !$response->is_success) {
              $response->{default_add_content} = 1;
          }
          elsif (!ref($arg) && length($arg)) {
              open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
  	    binmode($fh);
              push(@{$response->{handlers}{response_data}}, {
                  callback => sub {
                      print $fh $_[3] or die "Can't write to '$arg': $!";
                      1;
                  },
              });
              push(@{$response->{handlers}{response_done}}, {
                  callback => sub {
  		    close($fh) or die "Can't write to '$arg': $!";
  		    undef($fh);
  		},
  	    });
          }
          elsif (ref($arg) eq 'CODE') {
              push(@{$response->{handlers}{response_data}}, {
                  callback => sub {
  		    &$arg($_[3], $_[0], $self);
  		    1;
                  },
              });
          }
          else {
              die "Unexpected collect argument '$arg'";
          }
  
          $ua->run_handlers("response_header", $response);
  
          if (delete $response->{default_add_content}) {
              push(@{$response->{handlers}{response_data}}, {
  		callback => sub {
  		    $_[0]->add_content($_[3]);
  		    1;
  		},
  	    });
          }
  
  
          my $content_size = 0;
          my $length = $response->content_length;
          my %skip_h;
  
          while ($content = &$collector, length $$content) {
              for my $h ($ua->handlers("response_data", $response)) {
                  next if $skip_h{$h};
                  unless ($h->{callback}->($response, $ua, $h, $$content)) {
                      # XXX remove from $response->{handlers}{response_data} if present
                      $skip_h{$h}++;
                  }
              }
              $content_size += length($$content);
              $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
              if (defined($max_size) && $content_size > $max_size) {
                  $response->push_header("Client-Aborted", "max_size");
                  last;
              }
          }
      };
      my $err = $@;
      delete $response->{handlers}{response_data};
      delete $response->{handlers} unless %{$response->{handlers}};
      if ($err) {
          chomp($err);
          $response->push_header('X-Died' => $err);
          $response->push_header("Client-Aborted", "die");
          return $response;
      }
  
      return $response;
  }
  
  
  sub collect_once
  {
      my($self, $arg, $response) = @_;
      my $content = \ $_[3];
      my $first = 1;
      $self->collect($arg, $response, sub {
  	return $content if $first--;
  	return \ "";
      });
  }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  LWP::Protocol - Base class for LWP protocols
  
  =head1 SYNOPSIS
  
   package LWP::Protocol::foo;
   require LWP::Protocol;
   @ISA=qw(LWP::Protocol);
  
  =head1 DESCRIPTION
  
  This class is used a the base class for all protocol implementations
  supported by the LWP library.
  
  When creating an instance of this class using
  C<LWP::Protocol::create($url)>, and you get an initialised subclass
  appropriate for that access method. In other words, the
  LWP::Protocol::create() function calls the constructor for one of its
  subclasses.
  
  All derived LWP::Protocol classes need to override the request()
  method which is used to service a request. The overridden method can
  make use of the collect() function to collect together chunks of data
  as it is received.
  
  The following methods and functions are provided:
  
  =over 4
  
  =item $prot = LWP::Protocol->new()
  
  The LWP::Protocol constructor is inherited by subclasses. As this is a
  virtual base class this method should B<not> be called directly.
  
  =item $prot = LWP::Protocol::create($scheme)
  
  Create an object of the class implementing the protocol to handle the
  given scheme. This is a function, not a method. It is more an object
  factory than a constructor. This is the function user agents should
  use to access protocols.
  
  =item $class = LWP::Protocol::implementor($scheme, [$class])
  
  Get and/or set implementor class for a scheme.  Returns '' if the
  specified scheme is not supported.
  
  =item $prot->request(...)
  
   $response = $protocol->request($request, $proxy, undef);
   $response = $protocol->request($request, $proxy, '/tmp/sss');
   $response = $protocol->request($request, $proxy, \&callback, 1024);
  
  Dispatches a request over the protocol, and returns a response
  object. This method needs to be overridden in subclasses.  Refer to
  L<LWP::UserAgent> for description of the arguments.
  
  =item $prot->collect($arg, $response, $collector)
  
  Called to collect the content of a request, and process it
  appropriately into a scalar, file, or by calling a callback.  If $arg
  is undefined, then the content is stored within the $response.  If
  $arg is a simple scalar, then $arg is interpreted as a file name and
  the content is written to this file.  If $arg is a reference to a
  routine, then content is passed to this routine.
  
  The $collector is a routine that will be called and which is
  responsible for returning pieces (as ref to scalar) of the content to
  process.  The $collector signals EOF by returning a reference to an
  empty sting.
  
  The return value from collect() is the $response object reference.
  
  B<Note:> We will only use the callback or file argument if
  $response->is_success().  This avoids sending content data for
  redirects and authentication responses to the callback which would be
  confusing.
  
  =item $prot->collect_once($arg, $response, $content)
  
  Can be called when the whole response content is available as
  $content.  This will invoke collect() with a collector callback that
  returns a reference to $content the first time and an empty string the
  next.
  
  =back
  
  =head1 SEE ALSO
  
  Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
  for examples of usage.
  
  =head1 COPYRIGHT
  
  Copyright 1995-2001 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
LWP_PROTOCOL

$fatpacked{"LWP/Protocol/GHTTP.pm"} = <<'LWP_PROTOCOL_GHTTP';
  package LWP::Protocol::GHTTP;
  
  # You can tell LWP to use this module for 'http' requests by running
  # code like this before you make requests:
  #
  #    require LWP::Protocol::GHTTP;
  #    LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP');
  #
  
  use strict;
  use vars qw(@ISA);
  
  require LWP::Protocol;
  @ISA=qw(LWP::Protocol);
  
  require HTTP::Response;
  require HTTP::Status;
  
  use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST);
  
  my %METHOD =
  (
   GET  => METHOD_GET,
   HEAD => METHOD_HEAD,
   POST => METHOD_POST,
  );
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  
      my $method = $request->method;
      unless (exists $METHOD{$method}) {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   "Bad method '$method'");
      }
  
      my $r = HTTP::GHTTP->new($request->uri);
  
      # XXX what headers for repeated headers here?
      $request->headers->scan(sub { $r->set_header(@_)});
  
      $r->set_type($METHOD{$method});
  
      # XXX should also deal with subroutine content.
      my $cref = $request->content_ref;
      $r->set_body($$cref) if length($$cref);
  
      # XXX is this right
      $r->set_proxy($proxy->as_string) if $proxy;
  
      $r->process_request;
  
      my $response = HTTP::Response->new($r->get_status);
  
      # XXX How can get the headers out of $r??  This way is too stupid.
      my @headers;
      eval {
  	# Wrapped in eval because this method is not always available
  	@headers = $r->get_headers;
      };
      @headers = qw(Date Connection Server Content-type
                    Accept-Ranges Server
                    Content-Length Last-Modified ETag) if $@;
      for (@headers) {
  	my $v = $r->get_header($_);
  	$response->header($_ => $v) if defined $v;
      }
  
      return $self->collect_once($arg, $response, $r->get_body);
  }
  
  1;
LWP_PROTOCOL_GHTTP

$fatpacked{"LWP/Protocol/cpan.pm"} = <<'LWP_PROTOCOL_CPAN';
  package LWP::Protocol::cpan;
  
  use strict;
  use vars qw(@ISA);
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  require URI;
  require HTTP::Status;
  require HTTP::Response;
  
  our $CPAN;
  
  unless ($CPAN) {
      # Try to find local CPAN mirror via $CPAN::Config
      eval {
  	require CPAN::Config;
  	if($CPAN::Config) {
  	    my $urls = $CPAN::Config->{urllist};
  	    if (ref($urls) eq "ARRAY") {
  		my $file;
  		for (@$urls) {
  		    if (/^file:/) {
  			$file = $_;
  			last;
  		    }
  		}
  
  		if ($file) {
  		    $CPAN = $file;
  		}
  		else {
  		    $CPAN = $urls->[0];
  		}
  	    }
  	}
      };
  
      $CPAN ||= "http://cpan.org/";  # last resort
  }
  
  # ensure that we don't chop of last part
  $CPAN .= "/" unless $CPAN =~ m,/$,;
  
  
  sub request {
      my($self, $request, $proxy, $arg, $size) = @_;
      # check proxy
      if (defined $proxy)
      {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'You can not proxy with cpan');
      }
  
      # check method
      my $method = $request->method;
      unless ($method eq 'GET' || $method eq 'HEAD') {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'Library does not allow method ' .
  				   "$method for 'cpan:' URLs");
      }
  
      my $path = $request->uri->path;
      $path =~ s,^/,,;
  
      my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND);
      $response->header("Location" => URI->new_abs($path, $CPAN));
      $response;
  }
  
  1;
LWP_PROTOCOL_CPAN

$fatpacked{"LWP/Protocol/data.pm"} = <<'LWP_PROTOCOL_DATA';
  package LWP::Protocol::data;
  
  # Implements access to data:-URLs as specified in RFC 2397
  
  use strict;
  use vars qw(@ISA);
  
  require HTTP::Response;
  require HTTP::Status;
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  use HTTP::Date qw(time2str);
  require LWP;  # needs version number
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size) = @_;
  
      # check proxy
      if (defined $proxy)
      {
  	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  				  'You can not proxy with data');
      }
  
      # check method
      my $method = $request->method;
      unless ($method eq 'GET' || $method eq 'HEAD') {
  	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  				  'Library does not allow method ' .
  				  "$method for 'data:' URLs");
      }
  
      my $url = $request->uri;
      my $response = HTTP::Response->new( &HTTP::Status::RC_OK, "Document follows");
  
      my $media_type = $url->media_type;
  
      my $data = $url->data;
      $response->header('Content-Type'   => $media_type,
  		      'Content-Length' => length($data),
  		      'Date'           => time2str(time),
  		      'Server'         => "libwww-perl-internal/$LWP::VERSION"
  		     );
  
      $data = "" if $method eq "HEAD";
      return $self->collect_once($arg, $response, $data);
  }
  
  1;
LWP_PROTOCOL_DATA

$fatpacked{"LWP/Protocol/file.pm"} = <<'LWP_PROTOCOL_FILE';
  package LWP::Protocol::file;
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  use strict;
  
  require LWP::MediaTypes;
  require HTTP::Request;
  require HTTP::Response;
  require HTTP::Status;
  require HTTP::Date;
  
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size) = @_;
  
      $size = 4096 unless defined $size and $size > 0;
  
      # check proxy
      if (defined $proxy)
      {
  	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  				  'You can not proxy through the filesystem');
      }
  
      # check method
      my $method = $request->method;
      unless ($method eq 'GET' || $method eq 'HEAD') {
  	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  				  'Library does not allow method ' .
  				  "$method for 'file:' URLs");
      }
  
      # check url
      my $url = $request->uri;
  
      my $scheme = $url->scheme;
      if ($scheme ne 'file') {
  	return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  			   "LWP::Protocol::file::request called for '$scheme'");
      }
  
      # URL OK, look at file
      my $path  = $url->file;
  
      # test file exists and is readable
      unless (-e $path) {
  	return HTTP::Response->new( &HTTP::Status::RC_NOT_FOUND,
  				  "File `$path' does not exist");
      }
      unless (-r _) {
  	return HTTP::Response->new( &HTTP::Status::RC_FORBIDDEN,
  				  'User does not have read permission');
      }
  
      # looks like file exists
      my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
         $atime,$mtime,$ctime,$blksize,$blocks)
  	    = stat(_);
  
      # XXX should check Accept headers?
  
      # check if-modified-since
      my $ims = $request->header('If-Modified-Since');
      if (defined $ims) {
  	my $time = HTTP::Date::str2time($ims);
  	if (defined $time and $time >= $mtime) {
  	    return HTTP::Response->new( &HTTP::Status::RC_NOT_MODIFIED,
  				      "$method $path");
  	}
      }
  
      # Ok, should be an OK response by now...
      my $response = HTTP::Response->new( &HTTP::Status::RC_OK );
  
      # fill in response headers
      $response->header('Last-Modified', HTTP::Date::time2str($mtime));
  
      if (-d _) {         # If the path is a directory, process it
  	# generate the HTML for directory
  	opendir(D, $path) or
  	   return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  				     "Cannot read directory '$path': $!");
  	my(@files) = sort readdir(D);
  	closedir(D);
  
  	# Make directory listing
  	require URI::Escape;
  	require HTML::Entities;
          my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
  	for (@files) {
  	    my $furl = URI::Escape::uri_escape($_);
              if ( -d "$pathe$_" ) {
                  $furl .= '/';
                  $_ .= '/';
              }
  	    my $desc = HTML::Entities::encode($_);
  	    $_ = qq{<LI><A HREF="$furl">$desc</A>};
  	}
  	# Ensure that the base URL is "/" terminated
  	my $base = $url->clone;
  	unless ($base->path =~ m|/$|) {
  	    $base->path($base->path . "/");
  	}
  	my $html = join("\n",
  			"<HTML>\n<HEAD>",
  			"<TITLE>Directory $path</TITLE>",
  			"<BASE HREF=\"$base\">",
  			"</HEAD>\n<BODY>",
  			"<H1>Directory listing of $path</H1>",
  			"<UL>", @files, "</UL>",
  			"</BODY>\n</HTML>\n");
  
  	$response->header('Content-Type',   'text/html');
  	$response->header('Content-Length', length $html);
  	$html = "" if $method eq "HEAD";
  
  	return $self->collect_once($arg, $response, $html);
  
      }
  
      # path is a regular file
      $response->header('Content-Length', $filesize);
      LWP::MediaTypes::guess_media_type($path, $response);
  
      # read the file
      if ($method ne "HEAD") {
  	open(F, $path) or return new
  	    HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  			   "Cannot read file '$path': $!");
  	binmode(F);
  	$response =  $self->collect($arg, $response, sub {
  	    my $content = "";
  	    my $bytes = sysread(F, $content, $size);
  	    return \$content if $bytes > 0;
  	    return \ "";
  	});
  	close(F);
      }
  
      $response;
  }
  
  1;
LWP_PROTOCOL_FILE

$fatpacked{"LWP/Protocol/ftp.pm"} = <<'LWP_PROTOCOL_FTP';
  package LWP::Protocol::ftp;
  
  # Implementation of the ftp protocol (RFC 959). We let the Net::FTP
  # package do all the dirty work.
  
  use Carp ();
  
  use HTTP::Status ();
  use HTTP::Negotiate ();
  use HTTP::Response ();
  use LWP::MediaTypes ();
  use File::Listing ();
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  use strict;
  eval {
      package LWP::Protocol::MyFTP;
  
      require Net::FTP;
      Net::FTP->require_version(2.00);
  
      use vars qw(@ISA);
      @ISA=qw(Net::FTP);
  
      sub new {
  	my $class = shift;
  
  	my $self = $class->SUPER::new(@_) || return undef;
  
  	my $mess = $self->message;  # welcome message
  	$mess =~ s|\n.*||s; # only first line left
  	$mess =~ s|\s*ready\.?$||;
  	# Make the version number more HTTP like
  	$mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
  	${*$self}{myftp_server} = $mess;
  	#$response->header("Server", $mess);
  
  	$self;
      }
  
      sub http_server {
  	my $self = shift;
  	${*$self}{myftp_server};
      }
  
      sub home {
  	my $self = shift;
  	my $old = ${*$self}{myftp_home};
  	if (@_) {
  	    ${*$self}{myftp_home} = shift;
  	}
  	$old;
      }
  
      sub go_home {
  	my $self = shift;
  	$self->cwd(${*$self}{myftp_home});
      }
  
      sub request_count {
  	my $self = shift;
  	++${*$self}{myftp_reqcount};
      }
  
      sub ping {
  	my $self = shift;
  	return $self->go_home;
      }
  
  };
  my $init_failed = $@;
  
  
  sub _connect {
      my($self, $host, $port, $user, $account, $password, $timeout) = @_;
  
      my $key;
      my $conn_cache = $self->{ua}{conn_cache};
      if ($conn_cache) {
  	$key = "$host:$port:$user";
  	$key .= ":$account" if defined($account);
  	if (my $ftp = $conn_cache->withdraw("ftp", $key)) {
  	    if ($ftp->ping) {
  		# save it again
  		$conn_cache->deposit("ftp", $key, $ftp);
  		return $ftp;
  	    }
  	}
      }
  
      # try to make a connection
      my $ftp = LWP::Protocol::MyFTP->new($host,
  					Port => $port,
  					Timeout => $timeout,
  					LocalAddr => $self->{ua}{local_address},
  				       );
      # XXX Should be some what to pass on 'Passive' (header??)
      unless ($ftp) {
  	$@ =~ s/^Net::FTP: //;
  	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
      }
  
      unless ($ftp->login($user, $password, $account)) {
  	# Unauthorized.  Let's fake a RC_UNAUTHORIZED response
  	my $mess = scalar($ftp->message);
  	$mess =~ s/\n$//;
  	my $res =  HTTP::Response->new(&HTTP::Status::RC_UNAUTHORIZED, $mess);
  	$res->header("Server", $ftp->http_server);
  	$res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
  	return $res;
      }
  
      my $home = $ftp->pwd;
      $ftp->home($home);
  
      $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache;
  
      return $ftp;
  }
  
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  
      $size = 4096 unless $size;
  
      # check proxy
      if (defined $proxy)
      {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'You can not proxy through the ftp');
      }
  
      my $url = $request->uri;
      if ($url->scheme ne 'ftp') {
  	my $scheme = $url->scheme;
  	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  		       "LWP::Protocol::ftp::request called for '$scheme'");
      }
  
      # check method
      my $method = $request->method;
  
      unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'Library does not allow method ' .
  				   "$method for 'ftp:' URLs");
      }
  
      if ($init_failed) {
  	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  				   $init_failed);
      }
  
      my $host     = $url->host;
      my $port     = $url->port;
      my $user     = $url->user;
      my $password = $url->password;
  
      # If a basic autorization header is present than we prefer these over
      # the username/password specified in the URL.
      {
  	my($u,$p) = $request->authorization_basic;
  	if (defined $u) {
  	    $user = $u;
  	    $password = $p;
  	}
      }
  
      # We allow the account to be specified in the "Account" header
      my $account = $request->header('Account');
  
      my $ftp = $self->_connect($host, $port, $user, $account, $password, $timeout);
      return $ftp if ref($ftp) eq "HTTP::Response"; # ugh!
  
      # Create an initial response object
      my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
      $response->header(Server => $ftp->http_server);
      $response->header('Client-Request-Num' => $ftp->request_count);
      $response->request($request);
  
      # Get & fix the path
      my @path =  grep { length } $url->path_segments;
      my $remote_file = pop(@path);
      $remote_file = '' unless defined $remote_file;
  
      my $type;
      if (ref $remote_file) {
  	my @params;
  	($remote_file, @params) = @$remote_file;
  	for (@params) {
  	    $type = $_ if s/^type=//;
  	}
      }
  
      if ($type && $type eq 'a') {
  	$ftp->ascii;
      }
      else {
  	$ftp->binary;
      }
  
      for (@path) {
  	unless ($ftp->cwd($_)) {
  	    return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  				       "Can't chdir to $_");
  	}
      }
  
      if ($method eq 'GET' || $method eq 'HEAD') {
  	if (my $mod_time = $ftp->mdtm($remote_file)) {
  	    $response->last_modified($mod_time);
  	    if (my $ims = $request->if_modified_since) {
  		if ($mod_time <= $ims) {
  		    $response->code(&HTTP::Status::RC_NOT_MODIFIED);
  		    $response->message("Not modified");
  		    return $response;
  		}
  	    }
  	}
  
  	# We'll use this later to abort the transfer if necessary. 
  	# if $max_size is defined, we need to abort early. Otherwise, it's
        # a normal transfer
  	my $max_size = undef;
  
  	# Set resume location, if the client requested it
  	if ($request->header('Range') && $ftp->supported('REST'))
  	{
  		my $range_info = $request->header('Range');
  
  		# Change bytes=2772992-6781209 to just 2772992
  		my ($start_byte,$end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/;
  		if ( defined $start_byte && !defined $end_byte ) {
  
  		  # open range -- only the start is specified
  
  		  $ftp->restart( $start_byte );
  		  # don't define $max_size, we don't want to abort early
  		}
  		elsif ( defined $start_byte && defined $end_byte &&
  			$start_byte >= 0 && $end_byte >= $start_byte ) {
  
  		  $ftp->restart( $start_byte );
  		  $max_size = $end_byte - $start_byte;
  		}
  		else {
  
  		  return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  		     'Incorrect syntax for Range request');
  		}
  	}
  	elsif ($request->header('Range') && !$ftp->supported('REST'))
  	{
  		return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  	         "Server does not support resume.");
  	}
  
  	my $data;  # the data handle
  	if (length($remote_file) and $data = $ftp->retr($remote_file)) {
  	    my($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
  	    $response->header('Content-Type',   $type) if $type;
  	    for (@enc) {
  		$response->push_header('Content-Encoding', $_);
  	    }
  	    my $mess = $ftp->message;
  	    if ($mess =~ /\((\d+)\s+bytes\)/) {
  		$response->header('Content-Length', "$1");
  	    }
  
  	    if ($method ne 'HEAD') {
  		# Read data from server
  		$response = $self->collect($arg, $response, sub {
  		    my $content = '';
  		    my $result = $data->read($content, $size);
  
                      # Stop early if we need to.
                      if (defined $max_size)
                      {
                        # We need an interface to Net::FTP::dataconn for getting
                        # the number of bytes already read
                        my $bytes_received = $data->bytes_read();
  
                        # We were already over the limit. (Should only happen
                        # once at the end.)
                        if ($bytes_received - length($content) > $max_size)
                        {
                          $content = '';
                        }
                        # We just went over the limit
                        elsif ($bytes_received  > $max_size)
                        {
                          # Trim content
                          $content = substr($content, 0,
                            $max_size - ($bytes_received - length($content)) );
                        }
                        # We're under the limit
                        else
                        {
                        }
                      }
  
  		    return \$content;
  		} );
  	    }
  	    # abort is needed for HEAD, it's == close if the transfer has
  	    # already completed.
  	    unless ($data->abort) {
  		# Something did not work too well.  Note that we treat
  		# responses to abort() with code 0 in case of HEAD as ok
  		# (at least wu-ftpd 2.6.1(1) does that).
  		if ($method ne 'HEAD' || $ftp->code != 0) {
  		    $response->code(&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
  		    $response->message("FTP close response: " . $ftp->code .
  				       " " . $ftp->message);
  		}
  	    }
  	}
  	elsif (!length($remote_file) || ( $ftp->code >= 400 && $ftp->code < 600 )) {
  	    # not a plain file, try to list instead
  	    if (length($remote_file) && !$ftp->cwd($remote_file)) {
  		return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  					   "File '$remote_file' not found");
  	    }
  
  	    # It should now be safe to try to list the directory
  	    my @lsl = $ftp->dir;
  
  	    # Try to figure out if the user want us to convert the
  	    # directory listing to HTML.
  	    my @variants =
  	      (
  	       ['html',  0.60, 'text/html'            ],
  	       ['dir',   1.00, 'text/ftp-dir-listing' ]
  	      );
  	    #$HTTP::Negotiate::DEBUG=1;
  	    my $prefer = HTTP::Negotiate::choose(\@variants, $request);
  
  	    my $content = '';
  
  	    if (!defined($prefer)) {
  		return HTTP::Response->new(&HTTP::Status::RC_NOT_ACCEPTABLE,
  			       "Neither HTML nor directory listing wanted");
  	    }
  	    elsif ($prefer eq 'html') {
  		$response->header('Content-Type' => 'text/html');
  		$content = "<HEAD><TITLE>File Listing</TITLE>\n";
  		my $base = $request->uri->clone;
  		my $path = $base->path;
  		$base->path("$path/") unless $path =~ m|/$|;
  		$content .= qq(<BASE HREF="$base">\n</HEAD>\n);
  		$content .= "<BODY>\n<UL>\n";
  		for (File::Listing::parse_dir(\@lsl, 'GMT')) {
  		    my($name, $type, $size, $mtime, $mode) = @$_;
  		    $content .= qq(  <LI> <a href="$name">$name</a>);
  		    $content .= " $size bytes" if $type eq 'f';
  		    $content .= "\n";
  		}
  		$content .= "</UL></body>\n";
  	    }
  	    else {
  		$response->header('Content-Type', 'text/ftp-dir-listing');
  		$content = join("\n", @lsl, '');
  	    }
  
  	    $response->header('Content-Length', length($content));
  
  	    if ($method ne 'HEAD') {
  		$response = $self->collect_once($arg, $response, $content);
  	    }
  	}
  	else {
  	    my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  			  "FTP return code " . $ftp->code);
  	    $res->content_type("text/plain");
  	    $res->content($ftp->message);
  	    return $res;
  	}
      }
      elsif ($method eq 'PUT') {
  	# method must be PUT
  	unless (length($remote_file)) {
  	    return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				       "Must have a file name to PUT to");
  	}
  	my $data;
  	if ($data = $ftp->stor($remote_file)) {
  	    my $content = $request->content;
  	    my $bytes = 0;
  	    if (defined $content) {
  		if (ref($content) eq 'SCALAR') {
  		    $bytes = $data->write($$content, length($$content));
  		}
  		elsif (ref($content) eq 'CODE') {
  		    my($buf, $n);
  		    while (length($buf = &$content)) {
  			$n = $data->write($buf, length($buf));
  			last unless $n;
  			$bytes += $n;
  		    }
  		}
  		elsif (!ref($content)) {
  		    if (defined $content && length($content)) {
  			$bytes = $data->write($content, length($content));
  		    }
  		}
  		else {
  		    die "Bad content";
  		}
  	    }
  	    $data->close;
  
  	    $response->code(&HTTP::Status::RC_CREATED);
  	    $response->header('Content-Type', 'text/plain');
  	    $response->content("$bytes bytes stored as $remote_file on $host\n")
  
  	}
  	else {
  	    my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  					  "FTP return code " . $ftp->code);
  	    $res->content_type("text/plain");
  	    $res->content($ftp->message);
  	    return $res;
  	}
      }
      else {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   "Illegal method $method");
      }
  
      $response;
  }
  
  1;
  
  __END__
  
  # This is what RFC 1738 has to say about FTP access:
  # --------------------------------------------------
  #
  # 3.2. FTP
  #
  #    The FTP URL scheme is used to designate files and directories on
  #    Internet hosts accessible using the FTP protocol (RFC959).
  #
  #    A FTP URL follow the syntax described in Section 3.1.  If :<port> is
  #    omitted, the port defaults to 21.
  #
  # 3.2.1. FTP Name and Password
  #
  #    A user name and password may be supplied; they are used in the ftp
  #    "USER" and "PASS" commands after first making the connection to the
  #    FTP server.  If no user name or password is supplied and one is
  #    requested by the FTP server, the conventions for "anonymous" FTP are
  #    to be used, as follows:
  #
  #         The user name "anonymous" is supplied.
  #
  #         The password is supplied as the Internet e-mail address
  #         of the end user accessing the resource.
  #
  #    If the URL supplies a user name but no password, and the remote
  #    server requests a password, the program interpreting the FTP URL
  #    should request one from the user.
  #
  # 3.2.2. FTP url-path
  #
  #    The url-path of a FTP URL has the following syntax:
  #
  #         <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode>
  #
  #    Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings
  #    and <typecode> is one of the characters "a", "i", or "d".  The part
  #    ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be
  #    empty. The whole url-path may be omitted, including the "/"
  #    delimiting it from the prefix containing user, password, host, and
  #    port.
  #
  #    The url-path is interpreted as a series of FTP commands as follows:
  #
  #       Each of the <cwd> elements is to be supplied, sequentially, as the
  #       argument to a CWD (change working directory) command.
  #
  #       If the typecode is "d", perform a NLST (name list) command with
  #       <name> as the argument, and interpret the results as a file
  #       directory listing.
  #
  #       Otherwise, perform a TYPE command with <typecode> as the argument,
  #       and then access the file whose name is <name> (for example, using
  #       the RETR command.)
  #
  #    Within a name or CWD component, the characters "/" and ";" are
  #    reserved and must be encoded. The components are decoded prior to
  #    their use in the FTP protocol.  In particular, if the appropriate FTP
  #    sequence to access a particular file requires supplying a string
  #    containing a "/" as an argument to a CWD or RETR command, it is
  #    necessary to encode each "/".
  #
  #    For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is
  #    interpreted by FTP-ing to "host.dom", logging in as "myname"
  #    (prompting for a password if it is asked for), and then executing
  #    "CWD /etc" and then "RETR motd". This has a different meaning from
  #    <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then
  #    "RETR motd"; the initial "CWD" might be executed relative to the
  #    default directory for "myname". On the other hand,
  #    <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null
  #    argument, then "CWD etc", and then "RETR motd".
  #
  #    FTP URLs may also be used for other operations; for example, it is
  #    possible to update a file on a remote file server, or infer
  #    information about it from the directory listings. The mechanism for
  #    doing so is not spelled out here.
  #
  # 3.2.3. FTP Typecode is Optional
  #
  #    The entire ;type=<typecode> part of a FTP URL is optional. If it is
  #    omitted, the client program interpreting the URL must guess the
  #    appropriate mode to use. In general, the data content type of a file
  #    can only be guessed from the name, e.g., from the suffix of the name;
  #    the appropriate type code to be used for transfer of the file can
  #    then be deduced from the data content of the file.
  #
  # 3.2.4 Hierarchy
  #
  #    For some file systems, the "/" used to denote the hierarchical
  #    structure of the URL corresponds to the delimiter used to construct a
  #    file name hierarchy, and thus, the filename will look similar to the
  #    URL path. This does NOT mean that the URL is a Unix filename.
  #
  # 3.2.5. Optimization
  #
  #    Clients accessing resources via FTP may employ additional heuristics
  #    to optimize the interaction. For some FTP servers, for example, it
  #    may be reasonable to keep the control connection open while accessing
  #    multiple URLs from the same server. However, there is no common
  #    hierarchical model to the FTP protocol, so if a directory change
  #    command has been given, it is impossible in general to deduce what
  #    sequence should be given to navigate to another directory for a
  #    second retrieval, if the paths are different.  The only reliable
  #    algorithm is to disconnect and reestablish the control connection.
LWP_PROTOCOL_FTP

$fatpacked{"LWP/Protocol/gopher.pm"} = <<'LWP_PROTOCOL_GOPHER';
  package LWP::Protocol::gopher;
  
  # Implementation of the gopher protocol (RFC 1436)
  #
  # This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
  # which in turn is a vastly modified version of Oscar's http'get()
  # dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
  # including contributions from Marc van Heyningen and Martijn Koster.
  
  use strict;
  use vars qw(@ISA);
  
  require HTTP::Response;
  require HTTP::Status;
  require IO::Socket;
  require IO::Select;
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  
  my %gopher2mimetype = (
      '0' => 'text/plain',                # 0 file
      '1' => 'text/html',                 # 1 menu
  					# 2 CSO phone-book server
  					# 3 Error
      '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
      '5' => 'application/zip',           # 5 DOS binary archive of some sort
      '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
      '7' => 'text/html',                 # 7 Index-Search server
  					# 8 telnet session
      '9' => 'application/octet-stream',  # 9 binary file
      'h' => 'text/html',                 # html
      'g' => 'image/gif',                 # gif
      'I' => 'image/*',                   # some kind of image
  );
  
  my %gopher2encoding = (
      '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
  );
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  
      $size = 4096 unless $size;
  
      # check proxy
      if (defined $proxy) {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'You can not proxy through the gopher');
      }
  
      my $url = $request->uri;
      die "bad scheme" if $url->scheme ne 'gopher';
  
  
      my $method = $request->method;
      unless ($method eq 'GET' || $method eq 'HEAD') {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'Library does not allow method ' .
  				   "$method for 'gopher:' URLs");
      }
  
      my $gophertype = $url->gopher_type;
      unless (exists $gopher2mimetype{$gophertype}) {
  	return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  				   'Library does not support gophertype ' .
  				   $gophertype);
      }
  
      my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
      $response->header('Content-type' => $gopher2mimetype{$gophertype}
  					|| 'text/plain');
      $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
  	if exists $gopher2encoding{$gophertype};
  
      if ($method eq 'HEAD') {
  	# XXX: don't even try it so we set this header
  	$response->header('Client-Warning' => 'Client answer only');
  	return $response;
      }
      
      if ($gophertype eq '7' && ! $url->search) {
        # the url is the prompt for a gopher search; supply boiler-plate
        return $self->collect_once($arg, $response, <<"EOT");
  <HEAD>
  <TITLE>Gopher Index</TITLE>
  <ISINDEX>
  </HEAD>
  <BODY>
  <H1>$url<BR>Gopher Search</H1>
  This is a searchable Gopher index.
  Use the search function of your browser to enter search terms.
  </BODY>
  EOT
      }
  
      my $host = $url->host;
      my $port = $url->port;
  
      my $requestLine = "";
  
      my $selector = $url->selector;
      if (defined $selector) {
  	$requestLine .= $selector;
  	my $search = $url->search;
  	if (defined $search) {
  	    $requestLine .= "\t$search";
  	    my $string = $url->string;
  	    if (defined $string) {
  		$requestLine .= "\t$string";
  	    }
  	}
      }
      $requestLine .= "\015\012";
  
      # potential request headers are just ignored
  
      # Ok, lets make the request
      my $socket = IO::Socket::INET->new(PeerAddr => $host,
  				       PeerPort => $port,
  				       LocalAddr => $self->{ua}{local_address},
  				       Proto    => 'tcp',
  				       Timeout  => $timeout);
      die "Can't connect to $host:$port" unless $socket;
      my $sel = IO::Select->new($socket);
  
      {
  	die "write timeout" if $timeout && !$sel->can_write($timeout);
  	my $n = syswrite($socket, $requestLine, length($requestLine));
  	die $! unless defined($n);
  	die "short write" if $n != length($requestLine);
      }
  
      my $user_arg = $arg;
  
      # must handle menus in a special way since they are to be
      # converted to HTML.  Undefing $arg ensures that the user does
      # not see the data before we get a change to convert it.
      $arg = undef if $gophertype eq '1' || $gophertype eq '7';
  
      # collect response
      my $buf = '';
      $response = $self->collect($arg, $response, sub {
  	die "read timeout" if $timeout && !$sel->can_read($timeout);
          my $n = sysread($socket, $buf, $size);
  	die $! unless defined($n);
  	return \$buf;
        } );
  
      # Convert menu to HTML and return data to user.
      if ($gophertype eq '1' || $gophertype eq '7') {
  	my $content = menu2html($response->content);
  	if (defined $user_arg) {
  	    $response = $self->collect_once($user_arg, $response, $content);
  	}
  	else {
  	    $response->content($content);
  	}
      }
  
      $response;
  }
  
  
  sub gopher2url
  {
      my($gophertype, $path, $host, $port) = @_;
  
      my $url;
  
      if ($gophertype eq '8' || $gophertype eq 'T') {
  	# telnet session
  	$url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
  	$url->user($path) if defined $path;
      }
      else {
  	$path = URI::Escape::uri_escape($path);
  	$url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
      }
      $url->host($host);
      $url->port($port);
      $url;
  }
  
  sub menu2html {
      my($menu) = @_;
  
      $menu =~ s/\015//g;  # remove carriage return
      my $tmp = <<"EOT";
  <HTML>
  <HEAD>
     <TITLE>Gopher menu</TITLE>
  </HEAD>
  <BODY>
  <H1>Gopher menu</H1>
  EOT
      for (split("\n", $menu)) {
  	last if /^\./;
  	my($pretty, $path, $host, $port) = split("\t");
  
  	$pretty =~ s/^(.)//;
  	my $type = $1;
  
  	my $url = gopher2url($type, $path, $host, $port)->as_string;
  	$tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
      }
      $tmp .= "</BODY>\n</HTML>\n";
      $tmp;
  }
  
  1;
LWP_PROTOCOL_GOPHER

$fatpacked{"LWP/Protocol/http.pm"} = <<'LWP_PROTOCOL_HTTP';
  package LWP::Protocol::http;
  
  use strict;
  
  require HTTP::Response;
  require HTTP::Status;
  require Net::HTTP;
  
  use vars qw(@ISA @EXTRA_SOCK_OPTS);
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  my $CRLF = "\015\012";
  
  sub _new_socket
  {
      my($self, $host, $port, $timeout) = @_;
      my $conn_cache = $self->{ua}{conn_cache};
      if ($conn_cache) {
  	if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
  	    return $sock if $sock && !$sock->can_read(0);
  	    # if the socket is readable, then either the peer has closed the
  	    # connection or there are some garbage bytes on it.  In either
  	    # case we abandon it.
  	    $sock->close;
  	}
      }
  
      local($^W) = 0;  # IO::Socket::INET can be noisy
      my $sock = $self->socket_class->new(PeerAddr => $host,
  					PeerPort => $port,
  					LocalAddr => $self->{ua}{local_address},
  					Proto    => 'tcp',
  					Timeout  => $timeout,
  					KeepAlive => !!$conn_cache,
  					SendTE    => 1,
  					$self->_extra_sock_opts($host, $port),
  				       );
  
      unless ($sock) {
  	# IO::Socket::INET leaves additional error messages in $@
  	my $status = "Can't connect to $host:$port";
  	if ($@ =~ /\bconnect: (.*)/ ||
  	    $@ =~ /\b(Bad hostname)\b/ ||
  	    $@ =~ /\b(certificate verify failed)\b/ ||
  	    $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
  	) {
  	    $status .= " ($1)";
  	}
  	die "$status\n\n$@";
      }
  
      # perl 5.005's IO::Socket does not have the blocking method.
      eval { $sock->blocking(0); };
  
      $sock;
  }
  
  sub socket_type
  {
      return "http";
  }
  
  sub socket_class
  {
      my $self = shift;
      (ref($self) || $self) . "::Socket";
  }
  
  sub _extra_sock_opts  # to be overridden by subclass
  {
      return @EXTRA_SOCK_OPTS;
  }
  
  sub _check_sock
  {
      #my($self, $req, $sock) = @_;
  }
  
  sub _get_sock_info
  {
      my($self, $res, $sock) = @_;
      if (defined(my $peerhost = $sock->peerhost)) {
          $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
      }
  }
  
  sub _fixup_header
  {
      my($self, $h, $url, $proxy) = @_;
  
      # Extract 'Host' header
      my $hhost = $url->authority;
      if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
  	# add authorization header if we need them.  HTTP URLs do
  	# not really support specification of user and password, but
  	# we allow it.
  	if (defined($1) && not $h->header('Authorization')) {
  	    require URI::Escape;
  	    $h->authorization_basic(map URI::Escape::uri_unescape($_),
  				    split(":", $1, 2));
  	}
      }
      $h->init_header('Host' => $hhost);
  
      if ($proxy) {
  	# Check the proxy URI's userinfo() for proxy credentials
  	# export http_proxy="http://proxyuser:proxypass@proxyhost:port"
  	my $p_auth = $proxy->userinfo();
  	if(defined $p_auth) {
  	    require URI::Escape;
  	    $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
  					  split(":", $p_auth, 2))
  	}
      }
  }
  
  sub hlist_remove {
      my($hlist, $k) = @_;
      $k = lc $k;
      for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
  	next unless lc($hlist->[$i]) eq $k;
  	splice(@$hlist, $i, 2);
      }
  }
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  
      $size ||= 4096;
  
      # check method
      my $method = $request->method;
      unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
  	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  				  'Library does not allow method ' .
  				  "$method for 'http:' URLs");
      }
  
      my $url = $request->uri;
      my($host, $port, $fullpath);
  
      # Check if we're proxy'ing
      if (defined $proxy) {
  	# $proxy is an URL to an HTTP server which will proxy this request
  	$host = $proxy->host;
  	$port = $proxy->port;
  	$fullpath = $method eq "CONNECT" ?
                         ($url->host . ":" . $url->port) :
                         $url->as_string;
      }
      else {
  	$host = $url->host;
  	$port = $url->port;
  	$fullpath = $url->path_query;
  	$fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
      }
  
      # connect to remote site
      my $socket = $self->_new_socket($host, $port, $timeout);
  
      my $http_version = "";
      if (my $proto = $request->protocol) {
  	if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
  	    $http_version = $1;
  	    $socket->http_version($http_version);
  	    $socket->send_te(0) if $http_version eq "1.0";
  	}
      }
  
      $self->_check_sock($request, $socket);
  
      my @h;
      my $request_headers = $request->headers->clone;
      $self->_fixup_header($request_headers, $url, $proxy);
  
      $request_headers->scan(sub {
  			       my($k, $v) = @_;
  			       $k =~ s/^://;
  			       $v =~ s/\n/ /g;
  			       push(@h, $k, $v);
  			   });
  
      my $content_ref = $request->content_ref;
      $content_ref = $$content_ref if ref($$content_ref);
      my $chunked;
      my $has_content;
  
      if (ref($content_ref) eq 'CODE') {
  	my $clen = $request_headers->header('Content-Length');
  	$has_content++ if $clen;
  	unless (defined $clen) {
  	    push(@h, "Transfer-Encoding" => "chunked");
  	    $has_content++;
  	    $chunked++;
  	}
      }
      else {
  	# Set (or override) Content-Length header
  	my $clen = $request_headers->header('Content-Length');
  	if (defined($$content_ref) && length($$content_ref)) {
  	    $has_content = length($$content_ref);
  	    if (!defined($clen) || $clen ne $has_content) {
  		if (defined $clen) {
  		    warn "Content-Length header value was wrong, fixed";
  		    hlist_remove(\@h, 'Content-Length');
  		}
  		push(@h, 'Content-Length' => $has_content);
  	    }
  	}
  	elsif ($clen) {
  	    warn "Content-Length set when there is no content, fixed";
  	    hlist_remove(\@h, 'Content-Length');
  	}
      }
  
      my $write_wait = 0;
      $write_wait = 2
  	if ($request_headers->header("Expect") || "") =~ /100-continue/;
  
      my $req_buf = $socket->format_request($method, $fullpath, @h);
      #print "------\n$req_buf\n------\n";
  
      if (!$has_content || $write_wait || $has_content > 8*1024) {
        WRITE:
          {
              # Since this just writes out the header block it should almost
              # always succeed to send the whole buffer in a single write call.
              my $n = $socket->syswrite($req_buf, length($req_buf));
              unless (defined $n) {
                  redo WRITE if $!{EINTR};
                  if ($!{EAGAIN}) {
                      select(undef, undef, undef, 0.1);
                      redo WRITE;
                  }
                  die "write failed: $!";
              }
              if ($n) {
                  substr($req_buf, 0, $n, "");
              }
              else {
                  select(undef, undef, undef, 0.5);
              }
              redo WRITE if length $req_buf;
          }
      }
  
      my($code, $mess, @junk);
      my $drop_connection;
  
      if ($has_content) {
  	my $eof;
  	my $wbuf;
  	my $woffset = 0;
        INITIAL_READ:
  	if ($write_wait) {
  	    # skip filling $wbuf when waiting for 100-continue
  	    # because if the response is a redirect or auth required
  	    # the request will be cloned and there is no way
  	    # to reset the input stream
  	    # return here via the label after the 100-continue is read
  	}
  	elsif (ref($content_ref) eq 'CODE') {
  	    my $buf = &$content_ref();
  	    $buf = "" unless defined($buf);
  	    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
  		if $chunked;
  	    substr($buf, 0, 0) = $req_buf if $req_buf;
  	    $wbuf = \$buf;
  	}
  	else {
  	    if ($req_buf) {
  		my $buf = $req_buf . $$content_ref;
  		$wbuf = \$buf;
  	    }
  	    else {
  		$wbuf = $content_ref;
  	    }
  	    $eof = 1;
  	}
  
  	my $fbits = '';
  	vec($fbits, fileno($socket), 1) = 1;
  
        WRITE:
  	while ($write_wait || $woffset < length($$wbuf)) {
  
  	    my $sel_timeout = $timeout;
  	    if ($write_wait) {
  		$sel_timeout = $write_wait if $write_wait < $sel_timeout;
  	    }
  	    my $time_before;
              $time_before = time if $sel_timeout;
  
  	    my $rbits = $fbits;
  	    my $wbits = $write_wait ? undef : $fbits;
              my $sel_timeout_before = $sel_timeout;
            SELECT:
              {
                  my $nfound = select($rbits, $wbits, undef, $sel_timeout);
                  if ($nfound < 0) {
                      if ($!{EINTR} || $!{EAGAIN}) {
                          if ($time_before) {
                              $sel_timeout = $sel_timeout_before - (time - $time_before);
                              $sel_timeout = 0 if $sel_timeout < 0;
                          }
                          redo SELECT;
                      }
                      die "select failed: $!";
                  }
  	    }
  
  	    if ($write_wait) {
  		$write_wait -= time - $time_before;
  		$write_wait = 0 if $write_wait < 0;
  	    }
  
  	    if (defined($rbits) && $rbits =~ /[^\0]/) {
  		# readable
  		my $buf = $socket->_rbuf;
  		my $n = $socket->sysread($buf, 1024, length($buf));
                  unless (defined $n) {
                      die "read failed: $!" unless  $!{EINTR} || $!{EAGAIN};
                      # if we get here the rest of the block will do nothing
                      # and we will retry the read on the next round
                  }
  		elsif ($n == 0) {
                      # the server closed the connection before we finished
                      # writing all the request content.  No need to write any more.
                      $drop_connection++;
                      last WRITE;
  		}
  		$socket->_rbuf($buf);
  		if (!$code && $buf =~ /\015?\012\015?\012/) {
  		    # a whole response header is present, so we can read it without blocking
  		    ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
  									junk_out => \@junk,
  								       );
  		    if ($code eq "100") {
  			$write_wait = 0;
  			undef($code);
  			goto INITIAL_READ;
  		    }
  		    else {
  			$drop_connection++;
  			last WRITE;
  			# XXX should perhaps try to abort write in a nice way too
  		    }
  		}
  	    }
  	    if (defined($wbits) && $wbits =~ /[^\0]/) {
  		my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
                  unless (defined $n) {
                      die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
                      $n = 0;  # will retry write on the next round
                  }
                  elsif ($n == 0) {
  		    die "write failed: no bytes written";
  		}
  		$woffset += $n;
  
  		if (!$eof && $woffset >= length($$wbuf)) {
  		    # need to refill buffer from $content_ref code
  		    my $buf = &$content_ref();
  		    $buf = "" unless defined($buf);
  		    $eof++ unless length($buf);
  		    $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
  			if $chunked;
  		    $wbuf = \$buf;
  		    $woffset = 0;
  		}
  	    }
  	} # WRITE
      }
  
      ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
  	unless $code;
      ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
  	if $code eq "100";
  
      my $response = HTTP::Response->new($code, $mess);
      my $peer_http_version = $socket->peer_http_version;
      $response->protocol("HTTP/$peer_http_version");
      {
  	local $HTTP::Headers::TRANSLATE_UNDERSCORE;
  	$response->push_header(@h);
      }
      $response->push_header("Client-Junk" => \@junk) if @junk;
  
      $response->request($request);
      $self->_get_sock_info($response, $socket);
  
      if ($method eq "CONNECT") {
  	$response->{client_socket} = $socket;  # so it can be picked up
  	return $response;
      }
  
      if (my @te = $response->remove_header('Transfer-Encoding')) {
  	$response->push_header('Client-Transfer-Encoding', \@te);
      }
      $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
  
      my $complete;
      $response = $self->collect($arg, $response, sub {
  	my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
  	my $n;
        READ:
  	{
  	    $n = $socket->read_entity_body($buf, $size);
              unless (defined $n) {
                  redo READ if $!{EINTR} || $!{EAGAIN};
                  die "read failed: $!";
              }
  	    redo READ if $n == -1;
  	}
  	$complete++ if !$n;
          return \$buf;
      } );
      $drop_connection++ unless $complete;
  
      @h = $socket->get_trailers;
      if (@h) {
  	local $HTTP::Headers::TRANSLATE_UNDERSCORE;
  	$response->push_header(@h);
      }
  
      # keep-alive support
      unless ($drop_connection) {
  	if (my $conn_cache = $self->{ua}{conn_cache}) {
  	    my %connection = map { (lc($_) => 1) }
  		             split(/\s*,\s*/, ($response->header("Connection") || ""));
  	    if (($peer_http_version eq "1.1" && !$connection{close}) ||
  		$connection{"keep-alive"})
  	    {
  		$conn_cache->deposit($self->socket_type, "$host:$port", $socket);
  	    }
  	}
      }
  
      $response;
  }
  
  
  #-----------------------------------------------------------
  package LWP::Protocol::http::SocketMethods;
  
  sub ping {
      my $self = shift;
      !$self->can_read(0);
  }
  
  sub increment_response_count {
      my $self = shift;
      return ++${*$self}{'myhttp_response_count'};
  }
  
  #-----------------------------------------------------------
  package LWP::Protocol::http::Socket;
  use vars qw(@ISA);
  @ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
  
  1;
LWP_PROTOCOL_HTTP

$fatpacked{"LWP/Protocol/loopback.pm"} = <<'LWP_PROTOCOL_LOOPBACK';
  package LWP::Protocol::loopback;
  
  use strict;
  use vars qw(@ISA);
  require HTTP::Response;
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  sub request {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  
      my $response = HTTP::Response->new(200, "OK");
      $response->content_type("message/http; msgtype=request");
  
      $response->header("Via", "loopback/1.0 $proxy")
  	if $proxy;
  
      $response->header("X-Arg", $arg);
      $response->header("X-Read-Size", $size);
      $response->header("X-Timeout", $timeout);
  
      return $self->collect_once($arg, $response, $request->as_string);
  }
  
  1;
LWP_PROTOCOL_LOOPBACK

$fatpacked{"LWP/Protocol/mailto.pm"} = <<'LWP_PROTOCOL_MAILTO';
  package LWP::Protocol::mailto;
  
  # This module implements the mailto protocol.  It is just a simple
  # frontend to the Unix sendmail program except on MacOS, where it uses
  # Mail::Internet.
  
  require LWP::Protocol;
  require HTTP::Request;
  require HTTP::Response;
  require HTTP::Status;
  
  use Carp;
  use strict;
  use vars qw(@ISA $SENDMAIL);
  
  @ISA = qw(LWP::Protocol);
  
  unless ($SENDMAIL = $ENV{SENDMAIL}) {
      for my $sm (qw(/usr/sbin/sendmail
  		   /usr/lib/sendmail
  		   /usr/ucblib/sendmail
  		  ))
      {
  	if (-x $sm) {
  	    $SENDMAIL = $sm;
  	    last;
  	}
      }
      die "Can't find the 'sendmail' program" unless $SENDMAIL;
  }
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size) = @_;
  
      my ($mail, $addr) if $^O eq "MacOS";
      my @text = () if $^O eq "MacOS";
  
      # check proxy
      if (defined $proxy)
      {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				  'You can not proxy with mail');
      }
  
      # check method
      my $method = $request->method;
  
      if ($method ne 'POST') {
  	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
  				  'Library does not allow method ' .
  				  "$method for 'mailto:' URLs");
      }
  
      # check url
      my $url = $request->uri;
  
      my $scheme = $url->scheme;
      if ($scheme ne 'mailto') {
  	return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  			 "LWP::Protocol::mailto::request called for '$scheme'");
      }
      if ($^O eq "MacOS") {
  	eval {
  	    require Mail::Internet;
  	};
  	if($@) {
  	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  	               "You don't have MailTools installed");
  	}
  	unless ($ENV{SMTPHOSTS}) {
  	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  	               "You don't have SMTPHOSTS defined");
  	}
      }
      else {
  	unless (-x $SENDMAIL) {
  	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  	               "You don't have $SENDMAIL");
      }
      }
      if ($^O eq "MacOS") {
  	    $mail = Mail::Internet->new or
  	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  	    "Can't get a Mail::Internet object");
      }
      else {
  	open(SENDMAIL, "| $SENDMAIL -oi -t") or
  	    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  	               "Can't run $SENDMAIL: $!");
      }
      if ($^O eq "MacOS") {
  	$addr = $url->encoded822addr;
      }
      else {
  	$request = $request->clone;  # we modify a copy
  	my @h = $url->headers;  # URL headers override those in the request
  	while (@h) {
  	    my $k = shift @h;
  	    my $v = shift @h;
  	    next unless defined $v;
  	    if (lc($k) eq "body") {
  		$request->content($v);
  	    }
  	    else {
  		$request->push_header($k => $v);
  	    }
  	}
      }
      if ($^O eq "MacOS") {
  	$mail->add(To => $addr);
  	$mail->add(split(/[:\n]/,$request->headers_as_string));
      }
      else {
  	print SENDMAIL $request->headers_as_string;
  	print SENDMAIL "\n";
      }
      my $content = $request->content;
      if (defined $content) {
  	my $contRef = ref($content) ? $content : \$content;
  	if (ref($contRef) eq 'SCALAR') {
  	    if ($^O eq "MacOS") {
  		@text = split("\n",$$contRef);
  		foreach (@text) {
  		    $_ .= "\n";
  		}
  	    }
  	    else {
  	    print SENDMAIL $$contRef;
  	    }
  
  	}
  	elsif (ref($contRef) eq 'CODE') {
  	    # Callback provides data
  	    my $d;
  	    if ($^O eq "MacOS") {
  		my $stuff = "";
  		while (length($d = &$contRef)) {
  		    $stuff .= $d;
  		}
  		@text = split("\n",$stuff);
  		foreach (@text) {
  		    $_ .= "\n";
  		}
  	    }
  	    else {
  		print SENDMAIL $d;
  	    }
  	}
      }
      if ($^O eq "MacOS") {
  	$mail->body(\@text);
  	unless ($mail->smtpsend) {
  	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  				       "Mail::Internet->smtpsend unable to send message to <$addr>");
  	}
      }
      else {
  	unless (close(SENDMAIL)) {
  	    my $err = $! ? "$!" : "Exit status $?";
  	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  				       "$SENDMAIL: $err");
  	}
      }
  
  
      my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
  				       "Mail accepted");
      $response->header('Content-Type', 'text/plain');
      if ($^O eq "MacOS") {
  	$response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
  	$response->content("Message sent to <$addr>\n");
      }
      else {
  	$response->header('Server' => $SENDMAIL);
  	my $to = $request->header("To");
  	$response->content("Message sent to <$to>\n");
      }
  
      return $response;
  }
  
  1;
LWP_PROTOCOL_MAILTO

$fatpacked{"LWP/Protocol/nntp.pm"} = <<'LWP_PROTOCOL_NNTP';
  package LWP::Protocol::nntp;
  
  # Implementation of the Network News Transfer Protocol (RFC 977)
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  require HTTP::Response;
  require HTTP::Status;
  require Net::NNTP;
  
  use strict;
  
  
  sub request
  {
      my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  
      $size = 4096 unless $size;
  
      # Check for proxy
      if (defined $proxy) {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'You can not proxy through NNTP');
      }
  
      # Check that the scheme is as expected
      my $url = $request->uri;
      my $scheme = $url->scheme;
      unless ($scheme eq 'news' || $scheme eq 'nntp') {
  	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  				   "LWP::Protocol::nntp::request called for '$scheme'");
      }
  
      # check for a valid method
      my $method = $request->method;
      unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   'Library does not allow method ' .
  				   "$method for '$scheme:' URLs");
      }
  
      # extract the identifier and check against posting to an article
      my $groupart = $url->_group;
      my $is_art = $groupart =~ /@/;
  
      if ($is_art && $method eq 'POST') {
  	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  				   "Can't post to an article <$groupart>");
      }
  
      my $nntp = Net::NNTP->new($url->host,
  			      #Port    => 18574,
  			      Timeout => $timeout,
  			      #Debug   => 1,
  			     );
      die "Can't connect to nntp server" unless $nntp;
  
      # Check the initial welcome message from the NNTP server
      if ($nntp->status != 2) {
  	return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
  				   $nntp->message);
      }
      my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  
      my $mess = $nntp->message;
  
      # Try to extract server name from greeting message.
      # Don't know if this works well for a large class of servers, but
      # this works for our server.
      $mess =~ s/\s+ready\b.*//;
      $mess =~ s/^\S+\s+//;
      $response->header(Server => $mess);
  
      # First we handle posting of articles
      if ($method eq 'POST') {
  	$nntp->quit; $nntp = undef;
  	$response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
  	$response->message("POST not implemented yet");
  	return $response;
      }
  
      # The method must be "GET" or "HEAD" by now
      if (!$is_art) {
  	if (!$nntp->group($groupart)) {
  	    $response->code(&HTTP::Status::RC_NOT_FOUND);
  	    $response->message($nntp->message);
  	}
  	$nntp->quit; $nntp = undef;
  	# HEAD: just check if the group exists
  	if ($method eq 'GET' && $response->is_success) {
  	    $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
  	    $response->message("GET newsgroup not implemented yet");
  	}
  	return $response;
      }
  
      # Send command to server to retrieve an article (or just the headers)
      my $get = $method eq 'HEAD' ? "head" : "article";
      my $art = $nntp->$get("<$groupart>");
      unless ($art) {
  	$nntp->quit; $nntp = undef;
  	$response->code(&HTTP::Status::RC_NOT_FOUND);
  	$response->message($nntp->message);
  	return $response;
      }
  
      # Parse headers
      my($key, $val);
      local $_;
      while ($_ = shift @$art) {
  	if (/^\s+$/) {
  	    last;  # end of headers
  	}
  	elsif (/^(\S+):\s*(.*)/) {
  	    $response->push_header($key, $val) if $key;
  	    ($key, $val) = ($1, $2);
  	}
  	elsif (/^\s+(.*)/) {
  	    next unless $key;
  	    $val .= $1;
  	}
  	else {
  	    unshift(@$art, $_);
  	    last;
  	}
      }
      $response->push_header($key, $val) if $key;
  
      # Ensure that there is a Content-Type header
      $response->header("Content-Type", "text/plain")
  	unless $response->header("Content-Type");
  
      # Collect the body
      $response = $self->collect_once($arg, $response, join("", @$art))
        if @$art;
  
      # Say goodbye to the server
      $nntp->quit;
      $nntp = undef;
  
      $response;
  }
  
  1;
LWP_PROTOCOL_NNTP

$fatpacked{"LWP/Protocol/nogo.pm"} = <<'LWP_PROTOCOL_NOGO';
  package LWP::Protocol::nogo;
  # If you want to disable access to a particular scheme, use this
  # class and then call
  #   LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo');
  # For then on, attempts to access URLs with that scheme will generate
  # a 500 error.
  
  use strict;
  use vars qw(@ISA);
  require HTTP::Response;
  require HTTP::Status;
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  sub request {
      my($self, $request) = @_;
      my $scheme = $request->uri->scheme;
      
      return HTTP::Response->new(
        &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
        "Access to \'$scheme\' URIs has been disabled"
      );
  }
  1;
LWP_PROTOCOL_NOGO

$fatpacked{"LWP/RobotUA.pm"} = <<'LWP_ROBOTUA';
  package LWP::RobotUA;
  
  require LWP::UserAgent;
  @ISA = qw(LWP::UserAgent);
  $VERSION = "6.03";
  
  require WWW::RobotRules;
  require HTTP::Request;
  require HTTP::Response;
  
  use Carp ();
  use HTTP::Status ();
  use HTTP::Date qw(time2str);
  use strict;
  
  
  #
  # Additional attributes in addition to those found in LWP::UserAgent:
  #
  # $self->{'delay'}    Required delay between request to the same
  #                     server in minutes.
  #
  # $self->{'rules'}     A WWW::RobotRules object
  #
  
  sub new
  {
      my $class = shift;
      my %cnf;
      if (@_ < 4) {
  	# legacy args
  	@cnf{qw(agent from rules)} = @_;
      }
      else {
  	%cnf = @_;
      }
  
      Carp::croak('LWP::RobotUA agent required') unless $cnf{agent};
      Carp::croak('LWP::RobotUA from address required')
  	unless $cnf{from} && $cnf{from} =~ m/\@/;
  
      my $delay = delete $cnf{delay} || 1;
      my $use_sleep = delete $cnf{use_sleep};
      $use_sleep = 1 unless defined($use_sleep);
      my $rules = delete $cnf{rules};
  
      my $self = LWP::UserAgent->new(%cnf);
      $self = bless $self, $class;
  
      $self->{'delay'} = $delay;   # minutes
      $self->{'use_sleep'} = $use_sleep;
  
      if ($rules) {
  	$rules->agent($cnf{agent});
  	$self->{'rules'} = $rules;
      }
      else {
  	$self->{'rules'} = WWW::RobotRules->new($cnf{agent});
      }
  
      $self;
  }
  
  
  sub delay     { shift->_elem('delay',     @_); }
  sub use_sleep { shift->_elem('use_sleep', @_); }
  
  
  sub agent
  {
      my $self = shift;
      my $old = $self->SUPER::agent(@_);
      if (@_) {
  	# Changing our name means to start fresh
  	$self->{'rules'}->agent($self->{'agent'}); 
      }
      $old;
  }
  
  
  sub rules {
      my $self = shift;
      my $old = $self->_elem('rules', @_);
      $self->{'rules'}->agent($self->{'agent'}) if @_;
      $old;
  }
  
  
  sub no_visits
  {
      my($self, $netloc) = @_;
      $self->{'rules'}->no_visits($netloc) || 0;
  }
  
  *host_count = \&no_visits;  # backwards compatibility with LWP-5.02
  
  
  sub host_wait
  {
      my($self, $netloc) = @_;
      return undef unless defined $netloc;
      my $last = $self->{'rules'}->last_visit($netloc);
      if ($last) {
  	my $wait = int($self->{'delay'} * 60 - (time - $last));
  	$wait = 0 if $wait < 0;
  	return $wait;
      }
      return 0;
  }
  
  
  sub simple_request
  {
      my($self, $request, $arg, $size) = @_;
  
      # Do we try to access a new server?
      my $allowed = $self->{'rules'}->allowed($request->uri);
  
      if ($allowed < 0) {
  	# Host is not visited before, or robots.txt expired; fetch "robots.txt"
  	my $robot_url = $request->uri->clone;
  	$robot_url->path("robots.txt");
  	$robot_url->query(undef);
  
  	# make access to robot.txt legal since this will be a recursive call
  	$self->{'rules'}->parse($robot_url, ""); 
  
  	my $robot_req = HTTP::Request->new('GET', $robot_url);
  	my $parse_head = $self->parse_head(0);
  	my $robot_res = $self->request($robot_req);
  	$self->parse_head($parse_head);
  	my $fresh_until = $robot_res->fresh_until;
  	my $content = "";
  	if ($robot_res->is_success && $robot_res->content_is_text) {
  	    $content = $robot_res->decoded_content;
  	    $content = "" unless $content && $content =~ /^\s*Disallow\s*:/mi;
  	}
  	$self->{'rules'}->parse($robot_url, $content, $fresh_until);
  
  	# recalculate allowed...
  	$allowed = $self->{'rules'}->allowed($request->uri);
      }
  
      # Check rules
      unless ($allowed) {
  	my $res = HTTP::Response->new(
  	  &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt');
  	$res->request( $request ); # bind it to that request
  	return $res;
      }
  
      my $netloc = eval { local $SIG{__DIE__}; $request->uri->host_port; };
      my $wait = $self->host_wait($netloc);
  
      if ($wait) {
  	if ($self->{'use_sleep'}) {
  	    sleep($wait)
  	}
  	else {
  	    my $res = HTTP::Response->new(
  	      &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down');
  	    $res->header('Retry-After', time2str(time + $wait));
  	    $res->request( $request ); # bind it to that request
  	    return $res;
  	}
      }
  
      # Perform the request
      my $res = $self->SUPER::simple_request($request, $arg, $size);
  
      $self->{'rules'}->visit($netloc);
  
      $res;
  }
  
  
  sub as_string
  {
      my $self = shift;
      my @s;
      push(@s, "Robot: $self->{'agent'} operated by $self->{'from'}  [$self]");
      push(@s, "    Minimum delay: " . int($self->{'delay'}*60) . "s");
      push(@s, "    Will sleep if too early") if $self->{'use_sleep'};
      push(@s, "    Rules = $self->{'rules'}");
      join("\n", @s, '');
  }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  LWP::RobotUA - a class for well-behaved Web robots
  
  =head1 SYNOPSIS
  
    use LWP::RobotUA;
    my $ua = LWP::RobotUA->new('my-robot/0.1', 'me@foo.com');
    $ua->delay(10);  # be very nice -- max one hit every ten minutes!
    ...
  
    # Then just use it just like a normal LWP::UserAgent:
    my $response = $ua->get('http://whatever.int/...');
    ...
  
  =head1 DESCRIPTION
  
  This class implements a user agent that is suitable for robot
  applications.  Robots should be nice to the servers they visit.  They
  should consult the F</robots.txt> file to ensure that they are welcomed
  and they should not make requests too frequently.
  
  But before you consider writing a robot, take a look at
  <URL:http://www.robotstxt.org/>.
  
  When you use a I<LWP::RobotUA> object as your user agent, then you do not
  really have to think about these things yourself; C<robots.txt> files
  are automatically consulted and obeyed, the server isn't queried
  too rapidly, and so on.  Just send requests
  as you do when you are using a normal I<LWP::UserAgent>
  object (using C<< $ua->get(...) >>, C<< $ua->head(...) >>,
  C<< $ua->request(...) >>, etc.), and this
  special agent will make sure you are nice.
  
  =head1 METHODS
  
  The LWP::RobotUA is a sub-class of LWP::UserAgent and implements the
  same methods. In addition the following methods are provided:
  
  =over 4
  
  =item $ua = LWP::RobotUA->new( %options )
  
  =item $ua = LWP::RobotUA->new( $agent, $from )
  
  =item $ua = LWP::RobotUA->new( $agent, $from, $rules )
  
  The LWP::UserAgent options C<agent> and C<from> are mandatory.  The
  options C<delay>, C<use_sleep> and C<rules> initialize attributes
  private to the RobotUA.  If C<rules> are not provided, then
  C<WWW::RobotRules> is instantiated providing an internal database of
  F<robots.txt>.
  
  It is also possible to just pass the value of C<agent>, C<from> and
  optionally C<rules> as plain positional arguments.
  
  =item $ua->delay
  
  =item $ua->delay( $minutes )
  
  Get/set the minimum delay between requests to the same server, in
  I<minutes>.  The default is 1 minute.  Note that this number doesn't
  have to be an integer; for example, this sets the delay to 10 seconds:
  
      $ua->delay(10/60);
  
  =item $ua->use_sleep
  
  =item $ua->use_sleep( $boolean )
  
  Get/set a value indicating whether the UA should sleep() if requests
  arrive too fast, defined as $ua->delay minutes not passed since
  last request to the given server.  The default is TRUE.  If this value is
  FALSE then an internal SERVICE_UNAVAILABLE response will be generated.
  It will have an Retry-After header that indicates when it is OK to
  send another request to this server.
  
  =item $ua->rules
  
  =item $ua->rules( $rules )
  
  Set/get which I<WWW::RobotRules> object to use.
  
  =item $ua->no_visits( $netloc )
  
  Returns the number of documents fetched from this server host. Yeah I
  know, this method should probably have been named num_visits() or
  something like that. :-(
  
  =item $ua->host_wait( $netloc )
  
  Returns the number of I<seconds> (from now) you must wait before you can
  make a new request to this host.
  
  =item $ua->as_string
  
  Returns a string that describes the state of the UA.
  Mainly useful for debugging.
  
  =back
  
  =head1 SEE ALSO
  
  L<LWP::UserAgent>, L<WWW::RobotRules>
  
  =head1 COPYRIGHT
  
  Copyright 1996-2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
LWP_ROBOTUA

$fatpacked{"LWP/Simple.pm"} = <<'LWP_SIMPLE';
  package LWP::Simple;
  
  use strict;
  use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
  
  require Exporter;
  
  @EXPORT = qw(get head getprint getstore mirror);
  @EXPORT_OK = qw($ua);
  
  # I really hate this.  I was a bad idea to do it in the first place.
  # Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
  # for trivial tests)
  use HTTP::Status;
  push(@EXPORT, @HTTP::Status::EXPORT);
  
  $VERSION = "6.00";
  
  sub import
  {
      my $pkg = shift;
      my $callpkg = caller;
      Exporter::export($pkg, $callpkg, @_);
  }
  
  use LWP::UserAgent ();
  use HTTP::Status ();
  use HTTP::Date ();
  $ua = LWP::UserAgent->new;  # we create a global UserAgent object
  $ua->agent("LWP::Simple/$VERSION ");
  $ua->env_proxy;
  
  
  sub get ($)
  {
      my $response = $ua->get(shift);
      return $response->decoded_content if $response->is_success;
      return undef;
  }
  
  
  sub head ($)
  {
      my($url) = @_;
      my $request = HTTP::Request->new(HEAD => $url);
      my $response = $ua->request($request);
  
      if ($response->is_success) {
  	return $response unless wantarray;
  	return (scalar $response->header('Content-Type'),
  		scalar $response->header('Content-Length'),
  		HTTP::Date::str2time($response->header('Last-Modified')),
  		HTTP::Date::str2time($response->header('Expires')),
  		scalar $response->header('Server'),
  	       );
      }
      return;
  }
  
  
  sub getprint ($)
  {
      my($url) = @_;
      my $request = HTTP::Request->new(GET => $url);
      local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
      my $callback = sub { print $_[0] };
      if ($^O eq "MacOS") {
  	$callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
      }
      my $response = $ua->request($request, $callback);
      unless ($response->is_success) {
  	print STDERR $response->status_line, " <URL:$url>\n";
      }
      $response->code;
  }
  
  
  sub getstore ($$)
  {
      my($url, $file) = @_;
      my $request = HTTP::Request->new(GET => $url);
      my $response = $ua->request($request, $file);
  
      $response->code;
  }
  
  
  sub mirror ($$)
  {
      my($url, $file) = @_;
      my $response = $ua->mirror($url, $file);
      $response->code;
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  LWP::Simple - simple procedural interface to LWP
  
  =head1 SYNOPSIS
  
   perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
  
   use LWP::Simple;
   $content = get("http://www.sn.no/");
   die "Couldn't get it!" unless defined $content;
  
   if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
       ...
   }
  
   if (is_success(getprint("http://www.sn.no/"))) {
       ...
   }
  
  =head1 DESCRIPTION
  
  This module is meant for people who want a simplified view of the
  libwww-perl library.  It should also be suitable for one-liners.  If
  you need more control or access to the header fields in the requests
  sent and responses received, then you should use the full object-oriented
  interface provided by the C<LWP::UserAgent> module.
  
  The following functions are provided (and exported) by this module:
  
  =over 3
  
  =item get($url)
  
  The get() function will fetch the document identified by the given URL
  and return it.  It returns C<undef> if it fails.  The $url argument can
  be either a string or a reference to a URI object.
  
  You will not be able to examine the response code or response headers
  (like 'Content-Type') when you are accessing the web using this
  function.  If you need that information you should use the full OO
  interface (see L<LWP::UserAgent>).
  
  =item head($url)
  
  Get document headers. Returns the following 5 values if successful:
  ($content_type, $document_length, $modified_time, $expires, $server)
  
  Returns an empty list if it fails.  In scalar context returns TRUE if
  successful.
  
  =item getprint($url)
  
  Get and print a document identified by a URL. The document is printed
  to the selected default filehandle for output (normally STDOUT) as
  data is received from the network.  If the request fails, then the
  status code and message are printed on STDERR.  The return value is
  the HTTP response code.
  
  =item getstore($url, $file)
  
  Gets a document identified by a URL and stores it in the file. The
  return value is the HTTP response code.
  
  =item mirror($url, $file)
  
  Get and store a document identified by a URL, using
  I<If-modified-since>, and checking the I<Content-Length>.  Returns
  the HTTP response code.
  
  =back
  
  This module also exports the HTTP::Status constants and procedures.
  You can use them when you check the response code from getprint(),
  getstore() or mirror().  The constants are:
  
     RC_CONTINUE
     RC_SWITCHING_PROTOCOLS
     RC_OK
     RC_CREATED
     RC_ACCEPTED
     RC_NON_AUTHORITATIVE_INFORMATION
     RC_NO_CONTENT
     RC_RESET_CONTENT
     RC_PARTIAL_CONTENT
     RC_MULTIPLE_CHOICES
     RC_MOVED_PERMANENTLY
     RC_MOVED_TEMPORARILY
     RC_SEE_OTHER
     RC_NOT_MODIFIED
     RC_USE_PROXY
     RC_BAD_REQUEST
     RC_UNAUTHORIZED
     RC_PAYMENT_REQUIRED
     RC_FORBIDDEN
     RC_NOT_FOUND
     RC_METHOD_NOT_ALLOWED
     RC_NOT_ACCEPTABLE
     RC_PROXY_AUTHENTICATION_REQUIRED
     RC_REQUEST_TIMEOUT
     RC_CONFLICT
     RC_GONE
     RC_LENGTH_REQUIRED
     RC_PRECONDITION_FAILED
     RC_REQUEST_ENTITY_TOO_LARGE
     RC_REQUEST_URI_TOO_LARGE
     RC_UNSUPPORTED_MEDIA_TYPE
     RC_INTERNAL_SERVER_ERROR
     RC_NOT_IMPLEMENTED
     RC_BAD_GATEWAY
     RC_SERVICE_UNAVAILABLE
     RC_GATEWAY_TIMEOUT
     RC_HTTP_VERSION_NOT_SUPPORTED
  
  The HTTP::Status classification functions are:
  
  =over 3
  
  =item is_success($rc)
  
  True if response code indicated a successful request.
  
  =item is_error($rc)
  
  True if response code indicated that an error occurred.
  
  =back
  
  The module will also export the LWP::UserAgent object as C<$ua> if you
  ask for it explicitly.
  
  The user agent created by this module will identify itself as
  "LWP::Simple/#.##"
  and will initialize its proxy defaults from the environment (by
  calling $ua->env_proxy).
  
  =head1 CAVEAT
  
  Note that if you are using both LWP::Simple and the very popular CGI.pm
  module, you may be importing a C<head> function from each module,
  producing a warning like "Prototype mismatch: sub main::head ($) vs
  none". Get around this problem by just not importing LWP::Simple's
  C<head> function, like so:
  
          use LWP::Simple qw(!head);
          use CGI qw(:standard);  # then only CGI.pm defines a head()
  
  Then if you do need LWP::Simple's C<head> function, you can just call
  it as C<LWP::Simple::head($url)>.
  
  =head1 SEE ALSO
  
  L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
  L<lwp-mirror>
LWP_SIMPLE

$fatpacked{"LWP/UserAgent.pm"} = <<'LWP_USERAGENT';
  package LWP::UserAgent;
  
  use strict;
  use vars qw(@ISA $VERSION);
  
  require LWP::MemberMixin;
  @ISA = qw(LWP::MemberMixin);
  $VERSION = "6.05";
  
  use HTTP::Request ();
  use HTTP::Response ();
  use HTTP::Date ();
  
  use LWP ();
  use LWP::Protocol ();
  
  use Carp ();
  
  
  sub new
  {
      # Check for common user mistake
      Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference") 
          if ref($_[1]) eq 'HASH'; 
  
      my($class, %cnf) = @_;
  
      my $agent = delete $cnf{agent};
      my $from  = delete $cnf{from};
      my $def_headers = delete $cnf{default_headers};
      my $timeout = delete $cnf{timeout};
      $timeout = 3*60 unless defined $timeout;
      my $local_address = delete $cnf{local_address};
      my $ssl_opts = delete $cnf{ssl_opts} || {};
      unless (exists $ssl_opts->{verify_hostname}) {
  	# The processing of HTTPS_CA_* below is for compatibility with Crypt::SSLeay
  	if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) {
  	    $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
  	}
  	elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) {
  	    # Crypt-SSLeay compatibility (verify peer certificate; but not the hostname)
  	    $ssl_opts->{verify_hostname} = 0;
  	    $ssl_opts->{SSL_verify_mode} = 1;
  	}
  	else {
  	    $ssl_opts->{verify_hostname} = 1;
  	}
      }
      unless (exists $ssl_opts->{SSL_ca_file}) {
  	if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
  	    $ssl_opts->{SSL_ca_file} = $ca_file;
  	}
      }
      unless (exists $ssl_opts->{SSL_ca_path}) {
  	if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
  	    $ssl_opts->{SSL_ca_path} = $ca_path;
  	}
      }
      my $use_eval = delete $cnf{use_eval};
      $use_eval = 1 unless defined $use_eval;
      my $parse_head = delete $cnf{parse_head};
      $parse_head = 1 unless defined $parse_head;
      my $show_progress = delete $cnf{show_progress};
      my $max_size = delete $cnf{max_size};
      my $max_redirect = delete $cnf{max_redirect};
      $max_redirect = 7 unless defined $max_redirect;
      my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY};
  
      my $cookie_jar = delete $cnf{cookie_jar};
      my $conn_cache = delete $cnf{conn_cache};
      my $keep_alive = delete $cnf{keep_alive};
      
      Carp::croak("Can't mix conn_cache and keep_alive")
  	  if $conn_cache && $keep_alive;
  
      my $protocols_allowed   = delete $cnf{protocols_allowed};
      my $protocols_forbidden = delete $cnf{protocols_forbidden};
      
      my $requests_redirectable = delete $cnf{requests_redirectable};
      $requests_redirectable = ['GET', 'HEAD']
        unless defined $requests_redirectable;
  
      # Actually ""s are just as good as 0's, but for concision we'll just say:
      Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
        if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
      Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
        if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
      Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
        if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';
  
  
      if (%cnf && $^W) {
  	Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
      }
  
      my $self = bless {
  		      def_headers  => $def_headers,
  		      timeout      => $timeout,
  		      local_address => $local_address,
  		      ssl_opts     => $ssl_opts,
  		      use_eval     => $use_eval,
                        show_progress=> $show_progress,
  		      max_size     => $max_size,
  		      max_redirect => $max_redirect,
                        proxy        => {},
  		      no_proxy     => [],
                        protocols_allowed     => $protocols_allowed,
                        protocols_forbidden   => $protocols_forbidden,
                        requests_redirectable => $requests_redirectable,
  		     }, $class;
  
      $self->agent(defined($agent) ? $agent : $class->_agent)
  	if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
      $self->from($from) if $from;
      $self->cookie_jar($cookie_jar) if $cookie_jar;
      $self->parse_head($parse_head);
      $self->env_proxy if $env_proxy;
  
      $self->protocols_allowed(  $protocols_allowed  ) if $protocols_allowed;
      $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
  
      if ($keep_alive) {
  	$conn_cache ||= { total_capacity => $keep_alive };
      }
      $self->conn_cache($conn_cache) if $conn_cache;
  
      return $self;
  }
  
  
  sub send_request
  {
      my($self, $request, $arg, $size) = @_;
      my($method, $url) = ($request->method, $request->uri);
      my $scheme = $url->scheme;
  
      local($SIG{__DIE__});  # protect against user defined die handlers
  
      $self->progress("begin", $request);
  
      my $response = $self->run_handlers("request_send", $request);
  
      unless ($response) {
          my $protocol;
  
          {
              # Honor object-specific restrictions by forcing protocol objects
              #  into class LWP::Protocol::nogo.
              my $x;
              if($x = $self->protocols_allowed) {
                  if (grep lc($_) eq $scheme, @$x) {
                  }
                  else {
                      require LWP::Protocol::nogo;
                      $protocol = LWP::Protocol::nogo->new;
                  }
              }
              elsif ($x = $self->protocols_forbidden) {
                  if(grep lc($_) eq $scheme, @$x) {
                      require LWP::Protocol::nogo;
                      $protocol = LWP::Protocol::nogo->new;
                  }
              }
              # else fall thru and create the protocol object normally
          }
  
          # Locate protocol to use
          my $proxy = $request->{proxy};
          if ($proxy) {
              $scheme = $proxy->scheme;
          }
  
          unless ($protocol) {
              $protocol = eval { LWP::Protocol::create($scheme, $self) };
              if ($@) {
                  $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
                  $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
                  if ($scheme eq "https") {
                      $response->message($response->message . " (LWP::Protocol::https not installed)");
                      $response->content_type("text/plain");
                      $response->content(<<EOT);
  LWP will support https URLs if the LWP::Protocol::https module
  is installed.
  EOT
                  }
              }
          }
  
          if (!$response && $self->{use_eval}) {
              # we eval, and turn dies into responses below
              eval {
                  $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) ||
  		    die "No response returned by $protocol";
              };
              if ($@) {
                  if (UNIVERSAL::isa($@, "HTTP::Response")) {
                      $response = $@;
                      $response->request($request);
                  }
                  else {
                      my $full = $@;
                      (my $status = $@) =~ s/\n.*//s;
                      $status =~ s/ at .* line \d+.*//s;  # remove file/line number
                      my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : &HTTP::Status::RC_INTERNAL_SERVER_ERROR;
                      $response = _new_response($request, $code, $status, $full);
                  }
              }
          }
          elsif (!$response) {
              $response = $protocol->request($request, $proxy,
                                             $arg, $size, $self->{timeout});
              # XXX: Should we die unless $response->is_success ???
          }
      }
  
      $response->request($request);  # record request for reference
      $response->header("Client-Date" => HTTP::Date::time2str(time));
  
      $self->run_handlers("response_done", $response);
  
      $self->progress("end", $response);
      return $response;
  }
  
  
  sub prepare_request
  {
      my($self, $request) = @_;
      die "Method missing" unless $request->method;
      my $url = $request->uri;
      die "URL missing" unless $url;
      die "URL must be absolute" unless $url->scheme;
  
      $self->run_handlers("request_preprepare", $request);
  
      if (my $def_headers = $self->{def_headers}) {
  	for my $h ($def_headers->header_field_names) {
  	    $request->init_header($h => [$def_headers->header($h)]);
  	}
      }
  
      $self->run_handlers("request_prepare", $request);
  
      return $request;
  }
  
  
  sub simple_request
  {
      my($self, $request, $arg, $size) = @_;
  
      # sanity check the request passed in
      if (defined $request) {
  	if (ref $request) {
  	    Carp::croak("You need a request object, not a " . ref($request) . " object")
  	      if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
  		 !$request->can('method') or !$request->can('uri');
  	}
  	else {
  	    Carp::croak("You need a request object, not '$request'");
  	}
      }
      else {
          Carp::croak("No request object passed in");
      }
  
      eval {
  	$request = $self->prepare_request($request);
      };
      if ($@) {
  	$@ =~ s/ at .* line \d+.*//s;  # remove file/line number
  	return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
      }
      return $self->send_request($request, $arg, $size);
  }
  
  
  sub request
  {
      my($self, $request, $arg, $size, $previous) = @_;
  
      my $response = $self->simple_request($request, $arg, $size);
      $response->previous($previous) if $previous;
  
      if ($response->redirects >= $self->{max_redirect}) {
          $response->header("Client-Warning" =>
                            "Redirect loop detected (max_redirect = $self->{max_redirect})");
          return $response;
      }
  
      if (my $req = $self->run_handlers("response_redirect", $response)) {
          return $self->request($req, $arg, $size, $response);
      }
  
      my $code = $response->code;
  
      if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
  	$code == &HTTP::Status::RC_FOUND or
  	$code == &HTTP::Status::RC_SEE_OTHER or
  	$code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
      {
  	my $referral = $request->clone;
  
  	# These headers should never be forwarded
  	$referral->remove_header('Host', 'Cookie');
  	
  	if ($referral->header('Referer') &&
  	    $request->uri->scheme eq 'https' &&
  	    $referral->uri->scheme eq 'http')
  	{
  	    # RFC 2616, section 15.1.3.
  	    # https -> http redirect, suppressing Referer
  	    $referral->remove_header('Referer');
  	}
  
  	if ($code == &HTTP::Status::RC_SEE_OTHER ||
  	    $code == &HTTP::Status::RC_FOUND) 
          {
  	    my $method = uc($referral->method);
  	    unless ($method eq "GET" || $method eq "HEAD") {
  		$referral->method("GET");
  		$referral->content("");
  		$referral->remove_content_headers;
  	    }
  	}
  
  	# And then we update the URL based on the Location:-header.
  	my $referral_uri = $response->header('Location');
  	{
  	    # Some servers erroneously return a relative URL for redirects,
  	    # so make it absolute if it not already is.
  	    local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
  	    my $base = $response->base;
  	    $referral_uri = "" unless defined $referral_uri;
  	    $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
  		            ->abs($base);
  	}
  	$referral->uri($referral_uri);
  
  	return $response unless $self->redirect_ok($referral, $response);
  	return $self->request($referral, $arg, $size, $response);
  
      }
      elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
  	     $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
  	    )
      {
  	my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
  	my $ch_header = $proxy ?  "Proxy-Authenticate" : "WWW-Authenticate";
  	my @challenge = $response->header($ch_header);
  	unless (@challenge) {
  	    $response->header("Client-Warning" => 
  			      "Missing Authenticate header");
  	    return $response;
  	}
  
  	require HTTP::Headers::Util;
  	CHALLENGE: for my $challenge (@challenge) {
  	    $challenge =~ tr/,/;/;  # "," is used to separate auth-params!!
  	    ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
  	    my $scheme = shift(@$challenge);
  	    shift(@$challenge); # no value
  	    $challenge = { @$challenge };  # make rest into a hash
  
  	    unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
  		$response->header("Client-Warning" => 
  				  "Bad authentication scheme '$scheme'");
  		return $response;
  	    }
  	    $scheme = $1;  # untainted now
  	    my $class = "LWP::Authen::\u$scheme";
  	    $class =~ s/-/_/g;
  
  	    no strict 'refs';
  	    unless (%{"$class\::"}) {
  		# try to load it
  		eval "require $class";
  		if ($@) {
  		    if ($@ =~ /^Can\'t locate/) {
  			$response->header("Client-Warning" =>
  					  "Unsupported authentication scheme '$scheme'");
  		    }
  		    else {
  			$response->header("Client-Warning" => $@);
  		    }
  		    next CHALLENGE;
  		}
  	    }
  	    unless ($class->can("authenticate")) {
  		$response->header("Client-Warning" =>
  				  "Unsupported authentication scheme '$scheme'");
  		next CHALLENGE;
  	    }
  	    return $class->authenticate($self, $proxy, $challenge, $response,
  					$request, $arg, $size);
  	}
  	return $response;
      }
      return $response;
  }
  
  
  #
  # Now the shortcuts...
  #
  sub get {
      require HTTP::Request::Common;
      my($self, @parameters) = @_;
      my @suff = $self->_process_colonic_headers(\@parameters,1);
      return $self->request( HTTP::Request::Common::GET( @parameters ), @suff );
  }
  
  
  sub post {
      require HTTP::Request::Common;
      my($self, @parameters) = @_;
      my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
      return $self->request( HTTP::Request::Common::POST( @parameters ), @suff );
  }
  
  
  sub head {
      require HTTP::Request::Common;
      my($self, @parameters) = @_;
      my @suff = $self->_process_colonic_headers(\@parameters,1);
      return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff );
  }
  
  
  sub put {
      require HTTP::Request::Common;
      my($self, @parameters) = @_;
      my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
      return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
  }
  
  
  sub delete {
      require HTTP::Request::Common;
      my($self, @parameters) = @_;
      my @suff = $self->_process_colonic_headers(\@parameters,1);
      return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
  }
  
  
  sub _process_colonic_headers {
      # Process :content_cb / :content_file / :read_size_hint headers.
      my($self, $args, $start_index) = @_;
  
      my($arg, $size);
      for(my $i = $start_index; $i < @$args; $i += 2) {
  	next unless defined $args->[$i];
  
  	#printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];
  
  	if($args->[$i] eq ':content_cb') {
  	    # Some sanity-checking...
  	    $arg = $args->[$i + 1];
  	    Carp::croak("A :content_cb value can't be undef") unless defined $arg;
  	    Carp::croak("A :content_cb value must be a coderef")
  		unless ref $arg and UNIVERSAL::isa($arg, 'CODE');
  	    
  	}
  	elsif ($args->[$i] eq ':content_file') {
  	    $arg = $args->[$i + 1];
  
  	    # Some sanity-checking...
  	    Carp::croak("A :content_file value can't be undef")
  		unless defined $arg;
  	    Carp::croak("A :content_file value can't be a reference")
  		if ref $arg;
  	    Carp::croak("A :content_file value can't be \"\"")
  		unless length $arg;
  
  	}
  	elsif ($args->[$i] eq ':read_size_hint') {
  	    $size = $args->[$i + 1];
  	    # Bother checking it?
  
  	}
  	else {
  	    next;
  	}
  	splice @$args, $i, 2;
  	$i -= 2;
      }
  
      # And return a suitable suffix-list for request(REQ,...)
  
      return             unless defined $arg;
      return $arg, $size if     defined $size;
      return $arg;
  }
  
  
  sub is_online {
      my $self = shift;
      return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI";
      return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,;
      return 0;
  }
  
  
  my @ANI = qw(- \ | /);
  
  sub progress {
      my($self, $status, $m) = @_;
      return unless $self->{show_progress};
  
      local($,, $\);
      if ($status eq "begin") {
          print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
          $self->{progress_start} = time;
          $self->{progress_lastp} = "";
          $self->{progress_ani} = 0;
      }
      elsif ($status eq "end") {
          delete $self->{progress_lastp};
          delete $self->{progress_ani};
          print STDERR $m->status_line;
          my $t = time - delete $self->{progress_start};
          print STDERR " (${t}s)" if $t;
          print STDERR "\n";
      }
      elsif ($status eq "tick") {
          print STDERR "$ANI[$self->{progress_ani}++]\b";
          $self->{progress_ani} %= @ANI;
      }
      else {
          my $p = sprintf "%3.0f%%", $status * 100;
          return if $p eq $self->{progress_lastp};
          print STDERR "$p\b\b\b\b";
          $self->{progress_lastp} = $p;
      }
      STDERR->flush;
  }
  
  
  #
  # This whole allow/forbid thing is based on man 1 at's way of doing things.
  #
  sub is_protocol_supported
  {
      my($self, $scheme) = @_;
      if (ref $scheme) {
  	# assume we got a reference to an URI object
  	$scheme = $scheme->scheme;
      }
      else {
  	Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
  	    if $scheme =~ /\W/;
  	$scheme = lc $scheme;
      }
  
      my $x;
      if(ref($self) and $x       = $self->protocols_allowed) {
        return 0 unless grep lc($_) eq $scheme, @$x;
      }
      elsif (ref($self) and $x = $self->protocols_forbidden) {
        return 0 if grep lc($_) eq $scheme, @$x;
      }
  
      local($SIG{__DIE__});  # protect against user defined die handlers
      $x = LWP::Protocol::implementor($scheme);
      return 1 if $x and $x ne 'LWP::Protocol::nogo';
      return 0;
  }
  
  
  sub protocols_allowed      { shift->_elem('protocols_allowed'    , @_) }
  sub protocols_forbidden    { shift->_elem('protocols_forbidden'  , @_) }
  sub requests_redirectable  { shift->_elem('requests_redirectable', @_) }
  
  
  sub redirect_ok
  {
      # RFC 2616, section 10.3.2 and 10.3.3 say:
      #  If the 30[12] status code is received in response to a request other
      #  than GET or HEAD, the user agent MUST NOT automatically redirect the
      #  request unless it can be confirmed by the user, since this might
      #  change the conditions under which the request was issued.
  
      # Note that this routine used to be just:
      #  return 0 if $_[1]->method eq "POST";  return 1;
  
      my($self, $new_request, $response) = @_;
      my $method = $response->request->method;
      return 0 unless grep $_ eq $method,
        @{ $self->requests_redirectable || [] };
      
      if ($new_request->uri->scheme eq 'file') {
        $response->header("Client-Warning" =>
  			"Can't redirect to a file:// URL!");
        return 0;
      }
      
      # Otherwise it's apparently okay...
      return 1;
  }
  
  
  sub credentials
  {
      my $self = shift;
      my $netloc = lc(shift);
      my $realm = shift || "";
      my $old = $self->{basic_authentication}{$netloc}{$realm};
      if (@_) {
          $self->{basic_authentication}{$netloc}{$realm} = [@_];
      }
      return unless $old;
      return @$old if wantarray;
      return join(":", @$old);
  }
  
  
  sub get_basic_credentials
  {
      my($self, $realm, $uri, $proxy) = @_;
      return if $proxy;
      return $self->credentials($uri->host_port, $realm);
  }
  
  
  sub timeout      { shift->_elem('timeout',      @_); }
  sub local_address{ shift->_elem('local_address',@_); }
  sub max_size     { shift->_elem('max_size',     @_); }
  sub max_redirect { shift->_elem('max_redirect', @_); }
  sub show_progress{ shift->_elem('show_progress', @_); }
  
  sub ssl_opts {
      my $self = shift;
      if (@_ == 1) {
  	my $k = shift;
  	return $self->{ssl_opts}{$k};
      }
      if (@_) {
  	my $old;
  	while (@_) {
  	    my($k, $v) = splice(@_, 0, 2);
  	    $old = $self->{ssl_opts}{$k} unless @_;
  	    if (defined $v) {
  		$self->{ssl_opts}{$k} = $v;
  	    }
  	    else {
  		delete $self->{ssl_opts}{$k};
  	    }
  	}
  	%{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_);
  	return $old;
      }
  
      return keys %{$self->{ssl_opts}};
  }
  
  sub parse_head {
      my $self = shift;
      if (@_) {
          my $flag = shift;
          my $parser;
          my $old = $self->set_my_handler("response_header", $flag ? sub {
                 my($response, $ua) = @_;
                 require HTML::HeadParser;
                 $parser = HTML::HeadParser->new;
                 $parser->xml_mode(1) if $response->content_is_xhtml;
                 $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
  
                 push(@{$response->{handlers}{response_data}}, {
  		   callback => sub {
  		       return unless $parser;
  		       unless ($parser->parse($_[3])) {
  			   my $h = $parser->header;
  			   my $r = $_[0];
  			   for my $f ($h->header_field_names) {
  			       $r->init_header($f, [$h->header($f)]);
  			   }
  			   undef($parser);
  		       }
  		   },
  	       });
  
              } : undef,
              m_media_type => "html",
          );
          return !!$old;
      }
      else {
          return !!$self->get_my_handler("response_header");
      }
  }
  
  sub cookie_jar {
      my $self = shift;
      my $old = $self->{cookie_jar};
      if (@_) {
  	my $jar = shift;
  	if (ref($jar) eq "HASH") {
  	    require HTTP::Cookies;
  	    $jar = HTTP::Cookies->new(%$jar);
  	}
  	$self->{cookie_jar} = $jar;
          $self->set_my_handler("request_prepare",
              $jar ? sub { $jar->add_cookie_header($_[0]); } : undef,
          );
          $self->set_my_handler("response_done",
              $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
          );
      }
      $old;
  }
  
  sub default_headers {
      my $self = shift;
      my $old = $self->{def_headers} ||= HTTP::Headers->new;
      if (@_) {
  	Carp::croak("default_headers not set to HTTP::Headers compatible object")
  	    unless @_ == 1 && $_[0]->can("header_field_names");
  	$self->{def_headers} = shift;
      }
      return $old;
  }
  
  sub default_header {
      my $self = shift;
      return $self->default_headers->header(@_);
  }
  
  sub _agent       { "libwww-perl/$LWP::VERSION" }
  
  sub agent {
      my $self = shift;
      if (@_) {
  	my $agent = shift;
          if ($agent) {
              $agent .= $self->_agent if $agent =~ /\s+$/;
          }
          else {
              undef($agent)
          }
          return $self->default_header("User-Agent", $agent);
      }
      return $self->default_header("User-Agent");
  }
  
  sub from {  # legacy
      my $self = shift;
      return $self->default_header("From", @_);
  }
  
  
  sub conn_cache {
      my $self = shift;
      my $old = $self->{conn_cache};
      if (@_) {
  	my $cache = shift;
  	if (ref($cache) eq "HASH") {
  	    require LWP::ConnCache;
  	    $cache = LWP::ConnCache->new(%$cache);
  	}
  	$self->{conn_cache} = $cache;
      }
      $old;
  }
  
  
  sub add_handler {
      my($self, $phase, $cb, %spec) = @_;
      $spec{line} ||= join(":", (caller)[1,2]);
      my $conf = $self->{handlers}{$phase} ||= do {
          require HTTP::Config;
          HTTP::Config->new;
      };
      $conf->add(%spec, callback => $cb);
  }
  
  sub set_my_handler {
      my($self, $phase, $cb, %spec) = @_;
      $spec{owner} = (caller(1))[3] unless exists $spec{owner};
      $self->remove_handler($phase, %spec);
      $spec{line} ||= join(":", (caller)[1,2]);
      $self->add_handler($phase, $cb, %spec) if $cb;
  }
  
  sub get_my_handler {
      my $self = shift;
      my $phase = shift;
      my $init = pop if @_ % 2;
      my %spec = @_;
      my $conf = $self->{handlers}{$phase};
      unless ($conf) {
          return unless $init;
          require HTTP::Config;
          $conf = $self->{handlers}{$phase} = HTTP::Config->new;
      }
      $spec{owner} = (caller(1))[3] unless exists $spec{owner};
      my @h = $conf->find(%spec);
      if (!@h && $init) {
          if (ref($init) eq "CODE") {
              $init->(\%spec);
          }
          elsif (ref($init) eq "HASH") {
              while (my($k, $v) = each %$init) {
                  $spec{$k} = $v;
              }
          }
          $spec{callback} ||= sub {};
          $spec{line} ||= join(":", (caller)[1,2]);
          $conf->add(\%spec);
          return \%spec;
      }
      return wantarray ? @h : $h[0];
  }
  
  sub remove_handler {
      my($self, $phase, %spec) = @_;
      if ($phase) {
          my $conf = $self->{handlers}{$phase} || return;
          my @h = $conf->remove(%spec);
          delete $self->{handlers}{$phase} if $conf->empty;
          return @h;
      }
  
      return unless $self->{handlers};
      return map $self->remove_handler($_), sort keys %{$self->{handlers}};
  }
  
  sub handlers {
      my($self, $phase, $o) = @_;
      my @h;
      if ($o->{handlers} && $o->{handlers}{$phase}) {
          push(@h, @{$o->{handlers}{$phase}});
      }
      if (my $conf = $self->{handlers}{$phase}) {
          push(@h, $conf->matching($o));
      }
      return @h;
  }
  
  sub run_handlers {
      my($self, $phase, $o) = @_;
      if (defined(wantarray)) {
          for my $h ($self->handlers($phase, $o)) {
              my $ret = $h->{callback}->($o, $self, $h);
              return $ret if $ret;
          }
          return undef;
      }
  
      for my $h ($self->handlers($phase, $o)) {
          $h->{callback}->($o, $self, $h);
      }
  }
  
  
  # deprecated
  sub use_eval   { shift->_elem('use_eval',  @_); }
  sub use_alarm
  {
      Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
  	if @_ > 1 && $^W;
      "";
  }
  
  
  sub clone
  {
      my $self = shift;
      my $copy = bless { %$self }, ref $self;  # copy most fields
  
      delete $copy->{handlers};
      delete $copy->{conn_cache};
  
      # copy any plain arrays and hashes; known not to need recursive copy
      for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) {
          next unless $copy->{$k};
          if (ref($copy->{$k}) eq "ARRAY") {
              $copy->{$k} = [ @{$copy->{$k}} ];
          }
          elsif (ref($copy->{$k}) eq "HASH") {
              $copy->{$k} = { %{$copy->{$k}} };
          }
      }
  
      if ($self->{def_headers}) {
          $copy->{def_headers} = $self->{def_headers}->clone;
      }
  
      # re-enable standard handlers
      $copy->parse_head($self->parse_head);
  
      # no easy way to clone the cookie jar; so let's just remove it for now
      $copy->cookie_jar(undef);
  
      $copy;
  }
  
  
  sub mirror
  {
      my($self, $url, $file) = @_;
  
      my $request = HTTP::Request->new('GET', $url);
  
      # If the file exists, add a cache-related header
      if ( -e $file ) {
          my ($mtime) = ( stat($file) )[9];
          if ($mtime) {
              $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
          }
      }
      my $tmpfile = "$file-$$";
  
      my $response = $self->request($request, $tmpfile);
      if ( $response->header('X-Died') ) {
  	die $response->header('X-Died');
      }
  
      # Only fetching a fresh copy of the would be considered success.
      # If the file was not modified, "304" would returned, which 
      # is considered by HTTP::Status to be a "redirect", /not/ "success"
      if ( $response->is_success ) {
          my @stat        = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!";
          my $file_length = $stat[7];
          my ($content_length) = $response->header('Content-length');
  
          if ( defined $content_length and $file_length < $content_length ) {
              unlink($tmpfile);
              die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
          }
          elsif ( defined $content_length and $file_length > $content_length ) {
              unlink($tmpfile);
              die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
          }
          # The file was the expected length. 
          else {
              # Replace the stale file with a fresh copy
              if ( -e $file ) {
                  # Some dosish systems fail to rename if the target exists
                  chmod 0777, $file;
                  unlink $file;
              }
              rename( $tmpfile, $file )
                  or die "Cannot rename '$tmpfile' to '$file': $!\n";
  
              # make sure the file has the same last modification time
              if ( my $lm = $response->last_modified ) {
                  utime $lm, $lm, $file;
              }
          }
      }
      # The local copy is fresh enough, so just delete the temp file  
      else {
  	unlink($tmpfile);
      }
      return $response;
  }
  
  
  sub _need_proxy {
      my($req, $ua) = @_;
      return if exists $req->{proxy};
      my $proxy = $ua->{proxy}{$req->uri->scheme} || return;
      if ($ua->{no_proxy}) {
          if (my $host = eval { $req->uri->host }) {
              for my $domain (@{$ua->{no_proxy}}) {
                  if ($host =~ /\Q$domain\E$/) {
                      return;
                  }
              }
          }
      }
      $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
  }
  
  
  sub proxy
  {
      my $self = shift;
      my $key  = shift;
      return map $self->proxy($_, @_), @$key if ref $key;
  
      Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
      my $old = $self->{'proxy'}{$key};
      if (@_) {
          my $url = shift;
          if (defined($url) && length($url)) {
              Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/;
              Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://\w,;
          }
          $self->{proxy}{$key} = $url;
          $self->set_my_handler("request_preprepare", \&_need_proxy)
      }
      return $old;
  }
  
  
  sub env_proxy {
      my ($self) = @_;
      require Encode;
      require Encode::Locale;
      my($k,$v);
      while(($k, $v) = each %ENV) {
  	if ($ENV{REQUEST_METHOD}) {
  	    # Need to be careful when called in the CGI environment, as
  	    # the HTTP_PROXY variable is under control of that other guy.
  	    next if $k =~ /^HTTP_/;
  	    $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
  	}
  	$k = lc($k);
  	next unless $k =~ /^(.*)_proxy$/;
  	$k = $1;
  	if ($k eq 'no') {
  	    $self->no_proxy(split(/\s*,\s*/, $v));
  	}
  	else {
              # Ignore random _proxy variables, allow only valid schemes
              next unless $k =~ /^$URI::scheme_re\z/;
              # Ignore xxx_proxy variables if xxx isn't a supported protocol
              next unless LWP::Protocol::implementor($k);
  	    $self->proxy($k, Encode::decode(locale => $v));
  	}
      }
  }
  
  
  sub no_proxy {
      my($self, @no) = @_;
      if (@no) {
  	push(@{ $self->{'no_proxy'} }, @no);
      }
      else {
  	$self->{'no_proxy'} = [];
      }
  }
  
  
  sub _new_response {
      my($request, $code, $message, $content) = @_;
      $message ||= HTTP::Status::status_message($code);
      my $response = HTTP::Response->new($code, $message);
      $response->request($request);
      $response->header("Client-Date" => HTTP::Date::time2str(time));
      $response->header("Client-Warning" => "Internal response");
      $response->header("Content-Type" => "text/plain");
      $response->content($content || "$code $message\n");
      return $response;
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  LWP::UserAgent - Web user agent class
  
  =head1 SYNOPSIS
  
   require LWP::UserAgent;
   
   my $ua = LWP::UserAgent->new;
   $ua->timeout(10);
   $ua->env_proxy;
   
   my $response = $ua->get('http://search.cpan.org/');
   
   if ($response->is_success) {
       print $response->decoded_content;  # or whatever
   }
   else {
       die $response->status_line;
   }
  
  =head1 DESCRIPTION
  
  The C<LWP::UserAgent> is a class implementing a web user agent.
  C<LWP::UserAgent> objects can be used to dispatch web requests.
  
  In normal use the application creates an C<LWP::UserAgent> object, and
  then configures it with values for timeouts, proxies, name, etc. It
  then creates an instance of C<HTTP::Request> for the request that
  needs to be performed. This request is then passed to one of the
  request method the UserAgent, which dispatches it using the relevant
  protocol, and returns a C<HTTP::Response> object.  There are
  convenience methods for sending the most common request types: get(),
  head(), post(), put() and delete().  When using these methods then the
  creation of the request object is hidden as shown in the synopsis above.
  
  The basic approach of the library is to use HTTP style communication
  for all protocol schemes.  This means that you will construct
  C<HTTP::Request> objects and receive C<HTTP::Response> objects even
  for non-HTTP resources like I<gopher> and I<ftp>.  In order to achieve
  even more similarity to HTTP style communications, gopher menus and
  file directories are converted to HTML documents.
  
  =head1 CONSTRUCTOR METHODS
  
  The following constructor methods are available:
  
  =over 4
  
  =item $ua = LWP::UserAgent->new( %options )
  
  This method constructs a new C<LWP::UserAgent> object and returns it.
  Key/value pair arguments may be provided to set up the initial state.
  The following options correspond to attribute methods described below:
  
     KEY                     DEFAULT
     -----------             --------------------
     agent                   "libwww-perl/#.###"
     from                    undef
     conn_cache              undef
     cookie_jar              undef
     default_headers         HTTP::Headers->new
     local_address           undef
     ssl_opts		   { verify_hostname => 1 }
     max_size                undef
     max_redirect            7
     parse_head              1
     protocols_allowed       undef
     protocols_forbidden     undef
     requests_redirectable   ['GET', 'HEAD']
     timeout                 180
  
  The following additional options are also accepted: If the C<env_proxy> option
  is passed in with a TRUE value, then proxy settings are read from environment
  variables (see env_proxy() method below).  If C<env_proxy> isn't provided the
  C<PERL_LWP_ENV_PROXY> environment variable controls if env_proxy() is called
  during initialization.  If the C<keep_alive> option is passed in, then a
  C<LWP::ConnCache> is set up (see conn_cache() method below).  The C<keep_alive>
  value is passed on as the C<total_capacity> for the connection cache.
  
  =item $ua->clone
  
  Returns a copy of the LWP::UserAgent object.
  
  =back
  
  =head1 ATTRIBUTES
  
  The settings of the configuration attributes modify the behaviour of the
  C<LWP::UserAgent> when it dispatches requests.  Most of these can also
  be initialized by options passed to the constructor method.
  
  The following attribute methods are provided.  The attribute value is
  left unchanged if no argument is given.  The return value from each
  method is the old attribute value.
  
  =over
  
  =item $ua->agent
  
  =item $ua->agent( $product_id )
  
  Get/set the product token that is used to identify the user agent on
  the network.  The agent value is sent as the "User-Agent" header in
  the requests.  The default is the string returned by the _agent()
  method (see below).
  
  If the $product_id ends with space then the _agent() string is
  appended to it.
  
  The user agent string should be one or more simple product identifiers
  with an optional version number separated by the "/" character.
  Examples are:
  
    $ua->agent('Checkbot/0.4 ' . $ua->_agent);
    $ua->agent('Checkbot/0.4 ');    # same as above
    $ua->agent('Mozilla/5.0');
    $ua->agent("");                 # don't identify
  
  =item $ua->_agent
  
  Returns the default agent identifier.  This is a string of the form
  "libwww-perl/#.###", where "#.###" is substituted with the version number
  of this library.
  
  =item $ua->from
  
  =item $ua->from( $email_address )
  
  Get/set the e-mail address for the human user who controls
  the requesting user agent.  The address should be machine-usable, as
  defined in RFC 822.  The C<from> value is send as the "From" header in
  the requests.  Example:
  
    $ua->from('gaas@cpan.org');
  
  The default is to not send a "From" header.  See the default_headers()
  method for the more general interface that allow any header to be defaulted.
  
  =item $ua->cookie_jar
  
  =item $ua->cookie_jar( $cookie_jar_obj )
  
  Get/set the cookie jar object to use.  The only requirement is that
  the cookie jar object must implement the extract_cookies($request) and
  add_cookie_header($response) methods.  These methods will then be
  invoked by the user agent as requests are sent and responses are
  received.  Normally this will be a C<HTTP::Cookies> object or some
  subclass.
  
  The default is to have no cookie_jar, i.e. never automatically add
  "Cookie" headers to the requests.
  
  Shortcut: If a reference to a plain hash is passed in as the
  $cookie_jar_object, then it is replaced with an instance of
  C<HTTP::Cookies> that is initialized based on the hash.  This form also
  automatically loads the C<HTTP::Cookies> module.  It means that:
  
    $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });
  
  is really just a shortcut for:
  
    require HTTP::Cookies;
    $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));
  
  =item $ua->default_headers
  
  =item $ua->default_headers( $headers_obj )
  
  Get/set the headers object that will provide default header values for
  any requests sent.  By default this will be an empty C<HTTP::Headers>
  object.
  
  =item $ua->default_header( $field )
  
  =item $ua->default_header( $field => $value )
  
  This is just a short-cut for $ua->default_headers->header( $field =>
  $value ). Example:
  
    $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
    $ua->default_header('Accept-Language' => "no, en");
  
  =item $ua->conn_cache
  
  =item $ua->conn_cache( $cache_obj )
  
  Get/set the C<LWP::ConnCache> object to use.  See L<LWP::ConnCache>
  for details.
  
  =item $ua->credentials( $netloc, $realm )
  
  =item $ua->credentials( $netloc, $realm, $uname, $pass )
  
  Get/set the user name and password to be used for a realm.
  
  The $netloc is a string of the form "<host>:<port>".  The username and
  password will only be passed to this server.  Example:
  
    $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
  
  =item $ua->local_address
  
  =item $ua->local_address( $address )
  
  Get/set the local interface to bind to for network connections.  The interface
  can be specified as a hostname or an IP address.  This value is passed as the
  C<LocalAddr> argument to L<IO::Socket::INET>.
  
  =item $ua->max_size
  
  =item $ua->max_size( $bytes )
  
  Get/set the size limit for response content.  The default is C<undef>,
  which means that there is no limit.  If the returned response content
  is only partial, because the size limit was exceeded, then a
  "Client-Aborted" header will be added to the response.  The content
  might end up longer than C<max_size> as we abort once appending a
  chunk of data makes the length exceed the limit.  The "Content-Length"
  header, if present, will indicate the length of the full content and
  will normally not be the same as C<< length($res->content) >>.
  
  =item $ua->max_redirect
  
  =item $ua->max_redirect( $n )
  
  This reads or sets the object's limit of how many times it will obey
  redirection responses in a given request cycle.
  
  By default, the value is 7. This means that if you call request()
  method and the response is a redirect elsewhere which is in turn a
  redirect, and so on seven times, then LWP gives up after that seventh
  request.
  
  =item $ua->parse_head
  
  =item $ua->parse_head( $boolean )
  
  Get/set a value indicating whether we should initialize response
  headers from the E<lt>head> section of HTML documents. The default is
  TRUE.  Do not turn this off, unless you know what you are doing.
  
  =item $ua->protocols_allowed
  
  =item $ua->protocols_allowed( \@protocols )
  
  This reads (or sets) this user agent's list of protocols that the
  request methods will exclusively allow.  The protocol names are case
  insensitive.
  
  For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
  means that this user agent will I<allow only> those protocols,
  and attempts to use this user agent to access URLs with any other
  schemes (like "ftp://...") will result in a 500 error.
  
  To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)>
  
  By default, an object has neither a C<protocols_allowed> list, nor a
  C<protocols_forbidden> list.
  
  Note that having a C<protocols_allowed> list causes any
  C<protocols_forbidden> list to be ignored.
  
  =item $ua->protocols_forbidden
  
  =item $ua->protocols_forbidden( \@protocols )
  
  This reads (or sets) this user agent's list of protocols that the
  request method will I<not> allow. The protocol names are case
  insensitive.
  
  For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
  means that this user agent will I<not> allow those protocols, and
  attempts to use this user agent to access URLs with those schemes
  will result in a 500 error.
  
  To delete the list, call: C<$ua-E<gt>protocols_forbidden(undef)>
  
  =item $ua->requests_redirectable
  
  =item $ua->requests_redirectable( \@requests )
  
  This reads or sets the object's list of request names that
  C<$ua-E<gt>redirect_ok(...)> will allow redirection for.  By
  default, this is C<['GET', 'HEAD']>, as per RFC 2616.  To
  change to include 'POST', consider:
  
     push @{ $ua->requests_redirectable }, 'POST';
  
  =item $ua->show_progress
  
  =item $ua->show_progress( $boolean )
  
  Get/set a value indicating whether a progress bar should be displayed
  on on the terminal as requests are processed. The default is FALSE.
  
  =item $ua->timeout
  
  =item $ua->timeout( $secs )
  
  Get/set the timeout value in seconds. The default timeout() value is
  180 seconds, i.e. 3 minutes.
  
  The requests is aborted if no activity on the connection to the server
  is observed for C<timeout> seconds.  This means that the time it takes
  for the complete transaction and the request() method to actually
  return might be longer.
  
  =item $ua->ssl_opts
  
  =item $ua->ssl_opts( $key )
  
  =item $ua->ssl_opts( $key => $value )
  
  Get/set the options for SSL connections.  Without argument return the list
  of options keys currently set.  With a single argument return the current
  value for the given option.  With 2 arguments set the option value and return
  the old.  Setting an option to the value C<undef> removes this option.
  
  The options that LWP relates to are:
  
  =over
  
  =item C<verify_hostname> => $bool
  
  When TRUE LWP will for secure protocol schemes ensure it connects to servers
  that have a valid certificate matching the expected hostname.  If FALSE no
  checks are made and you can't be sure that you communicate with the expected peer.
  The no checks behaviour was the default for libwww-perl-5.837 and earlier releases.
  
  This option is initialized from the L<PERL_LWP_SSL_VERIFY_HOSTNAME> environment
  variable.  If this environment variable isn't set; then C<verify_hostname>
  defaults to 1.
  
  =item C<SSL_ca_file> => $path
  
  The path to a file containing Certificate Authority certificates.
  A default setting for this option is provided by checking the environment
  variables C<PERL_LWP_SSL_CA_FILE> and C<HTTPS_CA_FILE> in order.
  
  =item C<SSL_ca_path> => $path
  
  The path to a directory containing files containing Certificate Authority
  certificates.
  A default setting for this option is provided by checking the environment
  variables C<PERL_LWP_SSL_CA_PATH> and C<HTTPS_CA_DIR> in order.
  
  =back
  
  Other options can be set and are processed directly by the SSL Socket implementation
  in use.  See L<IO::Socket::SSL> or L<Net::SSL> for details.
  
  The libwww-perl core no longer bundles protocol plugins for SSL.  You will need
  to install L<LWP::Protocol::https> separately to enable support for processing
  https-URLs.
  
  =back
  
  =head2 Proxy attributes
  
  The following methods set up when requests should be passed via a
  proxy server.
  
  =over
  
  =item $ua->proxy(\@schemes, $proxy_url)
  
  =item $ua->proxy($scheme, $proxy_url)
  
  Set/retrieve proxy URL for a scheme:
  
   $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
   $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
  
  The first form specifies that the URL is to be used for proxying of
  access methods listed in the list in the first method argument,
  i.e. 'http' and 'ftp'.
  
  The second form shows a shorthand form for specifying
  proxy URL for a single access scheme.
  
  =item $ua->no_proxy( $domain, ... )
  
  Do not proxy requests to the given domains.  Calling no_proxy without
  any domains clears the list of domains. Eg:
  
   $ua->no_proxy('localhost', 'example.com');
  
  =item $ua->env_proxy
  
  Load proxy settings from *_proxy environment variables.  You might
  specify proxies like this (sh-syntax):
  
    gopher_proxy=http://proxy.my.place/
    wais_proxy=http://proxy.my.place/
    no_proxy="localhost,example.com"
    export gopher_proxy wais_proxy no_proxy
  
  csh or tcsh users should use the C<setenv> command to define these
  environment variables.
  
  On systems with case insensitive environment variables there exists a
  name clash between the CGI environment variables and the C<HTTP_PROXY>
  environment variable normally picked up by env_proxy().  Because of
  this C<HTTP_PROXY> is not honored for CGI scripts.  The
  C<CGI_HTTP_PROXY> environment variable can be used instead.
  
  =back
  
  =head2 Handlers
  
  Handlers are code that injected at various phases during the
  processing of requests.  The following methods are provided to manage
  the active handlers:
  
  =over
  
  =item $ua->add_handler( $phase => \&cb, %matchspec )
  
  Add handler to be invoked in the given processing phase.  For how to
  specify %matchspec see L<HTTP::Config/"Matching">.
  
  The possible values $phase and the corresponding callback signatures are:
  
  =over
  
  =item request_preprepare => sub { my($request, $ua, $h) = @_; ... }
  
  The handler is called before the C<request_prepare> and other standard
  initialization of of the request.  This can be used to set up headers
  and attributes that the C<request_prepare> handler depends on.  Proxy
  initialization should take place here; but in general don't register
  handlers for this phase.
  
  =item request_prepare => sub { my($request, $ua, $h) = @_; ... }
  
  The handler is called before the request is sent and can modify the
  request any way it see fit.  This can for instance be used to add
  certain headers to specific requests.
  
  The method can assign a new request object to $_[0] to replace the
  request that is sent fully.
  
  The return value from the callback is ignored.  If an exception is
  raised it will abort the request and make the request method return a
  "400 Bad request" response.
  
  =item request_send => sub { my($request, $ua, $h) = @_; ... }
  
  This handler gets a chance of handling requests before they're sent to the
  protocol handlers.  It should return an HTTP::Response object if it
  wishes to terminate the processing; otherwise it should return nothing.
  
  The C<response_header> and C<response_data> handlers will not be
  invoked for this response, but the C<response_done> will be.
  
  =item response_header => sub { my($response, $ua, $h) = @_; ... }
  
  This handler is called right after the response headers have been
  received, but before any content data.  The handler might set up
  handlers for data and might croak to abort the request.
  
  The handler might set the $response->{default_add_content} value to
  control if any received data should be added to the response object
  directly.  This will initially be false if the $ua->request() method
  was called with a $content_file or $content_cb argument; otherwise true.
  
  =item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
  
  This handler is called for each chunk of data received for the
  response.  The handler might croak to abort the request.
  
  This handler needs to return a TRUE value to be called again for
  subsequent chunks for the same request.
  
  =item response_done => sub { my($response, $ua, $h) = @_; ... }
  
  The handler is called after the response has been fully received, but
  before any redirect handling is attempted.  The handler can be used to
  extract information or modify the response.
  
  =item response_redirect => sub { my($response, $ua, $h) = @_; ... }
  
  The handler is called in $ua->request after C<response_done>.  If the
  handler returns an HTTP::Request object we'll start over with processing
  this request instead.
  
  =back
  
  =item $ua->remove_handler( undef, %matchspec )
  
  =item $ua->remove_handler( $phase, %matchspec )
  
  Remove handlers that match the given %matchspec.  If $phase is not
  provided remove handlers from all phases.
  
  Be careful as calling this function with %matchspec that is not not
  specific enough can remove handlers not owned by you.  It's probably
  better to use the set_my_handler() method instead.
  
  The removed handlers are returned.
  
  =item $ua->set_my_handler( $phase, $cb, %matchspec )
  
  Set handlers private to the executing subroutine.  Works by defaulting
  an C<owner> field to the %matchspec that holds the name of the called
  subroutine.  You might pass an explicit C<owner> to override this.
  
  If $cb is passed as C<undef>, remove the handler.
  
  =item $ua->get_my_handler( $phase, %matchspec )
  
  =item $ua->get_my_handler( $phase, %matchspec, $init )
  
  Will retrieve the matching handler as hash ref.
  
  If C<$init> is passed passed as a TRUE value, create and add the
  handler if it's not found.  If $init is a subroutine reference, then
  it's called with the created handler hash as argument.  This sub might
  populate the hash with extra fields; especially the callback.  If
  $init is a hash reference, merge the hashes.
  
  =item $ua->handlers( $phase, $request )
  
  =item $ua->handlers( $phase, $response )
  
  Returns the handlers that apply to the given request or response at
  the given processing phase.
  
  =back
  
  =head1 REQUEST METHODS
  
  The methods described in this section are used to dispatch requests
  via the user agent.  The following request methods are provided:
  
  =over
  
  =item $ua->get( $url )
  
  =item $ua->get( $url , $field_name => $value, ... )
  
  This method will dispatch a C<GET> request on the given $url.  Further
  arguments can be given to initialize the headers of the request. These
  are given as separate name/value pairs.  The return value is a
  response object.  See L<HTTP::Response> for a description of the
  interface it provides.
  
  There will still be a response object returned when LWP can't connect to the
  server specified in the URL or when other failures in protocol handlers occur.
  These internal responses use the standard HTTP status codes, so the responses
  can't be differentiated by testing the response status code alone.  Error
  responses that LWP generates internally will have the "Client-Warning" header
  set to the value "Internal response".  If you need to differentiate these
  internal responses from responses that a remote server actually generates, you
  need to test this header value.
  
  Fields names that start with ":" are special.  These will not
  initialize headers of the request but will determine how the response
  content is treated.  The following special field names are recognized:
  
      :content_file   => $filename
      :content_cb     => \&callback
      :read_size_hint => $bytes
  
  If a $filename is provided with the C<:content_file> option, then the
  response content will be saved here instead of in the response
  object.  If a callback is provided with the C<:content_cb> option then
  this function will be called for each chunk of the response content as
  it is received from the server.  If neither of these options are
  given, then the response content will accumulate in the response
  object itself.  This might not be suitable for very large response
  bodies.  Only one of C<:content_file> or C<:content_cb> can be
  specified.  The content of unsuccessful responses will always
  accumulate in the response object itself, regardless of the
  C<:content_file> or C<:content_cb> options passed in.
  
  The C<:read_size_hint> option is passed to the protocol module which
  will try to read data from the server in chunks of this size.  A
  smaller value for the C<:read_size_hint> will result in a higher
  number of callback invocations.
  
  The callback function is called with 3 arguments: a chunk of data, a
  reference to the response object, and a reference to the protocol
  object.  The callback can abort the request by invoking die().  The
  exception message will show up as the "X-Died" header field in the
  response returned by the get() function.
  
  =item $ua->head( $url )
  
  =item $ua->head( $url , $field_name => $value, ... )
  
  This method will dispatch a C<HEAD> request on the given $url.
  Otherwise it works like the get() method described above.
  
  =item $ua->post( $url, \%form )
  
  =item $ua->post( $url, \@form )
  
  =item $ua->post( $url, \%form, $field_name => $value, ... )
  
  =item $ua->post( $url, $field_name => $value,... Content => \%form )
  
  =item $ua->post( $url, $field_name => $value,... Content => \@form )
  
  =item $ua->post( $url, $field_name => $value,... Content => $content )
  
  This method will dispatch a C<POST> request on the given $url, with
  %form or @form providing the key/value pairs for the fill-in form
  content. Additional headers and content options are the same as for
  the get() method.
  
  This method will use the POST() function from C<HTTP::Request::Common>
  to build the request.  See L<HTTP::Request::Common> for a details on
  how to pass form content and other advanced features.
  
  =item $ua->put( $url, \%form )
  
  =item $ua->put( $url, \@form )
  
  =item $ua->put( $url, \%form, $field_name => $value, ... )
  
  =item $ua->put( $url, $field_name => $value,... Content => \%form )
  
  =item $ua->put( $url, $field_name => $value,... Content => \@form )
  
  =item $ua->put( $url, $field_name => $value,... Content => $content )
  
  This method will dispatch a C<PUT> request on the given $url, with
  %form or @form providing the key/value pairs for the fill-in form
  content. Additional headers and content options are the same as for
  the get() method.
  
  This method will use the PUT() function from C<HTTP::Request::Common>
  to build the request.  See L<HTTP::Request::Common> for a details on
  how to pass form content and other advanced features.
  
  =item $ua->delete( $url )
  
  =item $ua->delete( $url, $field_name => $value, ... )
  
  This method will dispatch a C<DELETE> request on the given $url.  Additional
  headers and content options are the same as for the get() method.
  
  This method will use the DELETE() function from C<HTTP::Request::Common>
  to build the request.  See L<HTTP::Request::Common> for a details on
  how to pass form content and other advanced features.
  
  =item $ua->mirror( $url, $filename )
  
  This method will get the document identified by $url and store it in
  file called $filename.  If the file already exists, then the request
  will contain an "If-Modified-Since" header matching the modification
  time of the file.  If the document on the server has not changed since
  this time, then nothing happens.  If the document has been updated, it
  will be downloaded again.  The modification time of the file will be
  forced to match that of the server.
  
  The return value is the the response object.
  
  =item $ua->request( $request )
  
  =item $ua->request( $request, $content_file )
  
  =item $ua->request( $request, $content_cb )
  
  =item $ua->request( $request, $content_cb, $read_size_hint )
  
  This method will dispatch the given $request object.  Normally this
  will be an instance of the C<HTTP::Request> class, but any object with
  a similar interface will do.  The return value is a response object.
  See L<HTTP::Request> and L<HTTP::Response> for a description of the
  interface provided by these classes.
  
  The request() method will process redirects and authentication
  responses transparently.  This means that it may actually send several
  simple requests via the simple_request() method described below.
  
  The request methods described above; get(), head(), post() and
  mirror(), will all dispatch the request they build via this method.
  They are convenience methods that simply hides the creation of the
  request object for you.
  
  The $content_file, $content_cb and $read_size_hint all correspond to
  options described with the get() method above.
  
  You are allowed to use a CODE reference as C<content> in the request
  object passed in.  The C<content> function should return the content
  when called.  The content can be returned in chunks.  The content
  function will be invoked repeatedly until it return an empty string to
  signal that there is no more content.
  
  =item $ua->simple_request( $request )
  
  =item $ua->simple_request( $request, $content_file )
  
  =item $ua->simple_request( $request, $content_cb )
  
  =item $ua->simple_request( $request, $content_cb, $read_size_hint )
  
  This method dispatches a single request and returns the response
  received.  Arguments are the same as for request() described above.
  
  The difference from request() is that simple_request() will not try to
  handle redirects or authentication responses.  The request() method
  will in fact invoke this method for each simple request it sends.
  
  =item $ua->is_online
  
  Tries to determine if you have access to the Internet.  Returns
  TRUE if the built-in heuristics determine that the user agent is
  able to access the Internet (over HTTP).  See also L<LWP::Online>.
  
  =item $ua->is_protocol_supported( $scheme )
  
  You can use this method to test whether this user agent object supports the
  specified C<scheme>.  (The C<scheme> might be a string (like 'http' or
  'ftp') or it might be an URI object reference.)
  
  Whether a scheme is supported, is determined by the user agent's
  C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
  the capabilities of LWP.  I.e., this will return TRUE only if LWP
  supports this protocol I<and> it's permitted for this particular
  object.
  
  =back
  
  =head2 Callback methods
  
  The following methods will be invoked as requests are processed. These
  methods are documented here because subclasses of C<LWP::UserAgent>
  might want to override their behaviour.
  
  =over
  
  =item $ua->prepare_request( $request )
  
  This method is invoked by simple_request().  Its task is to modify the
  given $request object by setting up various headers based on the
  attributes of the user agent. The return value should normally be the
  $request object passed in.  If a different request object is returned
  it will be the one actually processed.
  
  The headers affected by the base implementation are; "User-Agent",
  "From", "Range" and "Cookie".
  
  =item $ua->redirect_ok( $prospective_request, $response )
  
  This method is called by request() before it tries to follow a
  redirection to the request in $response.  This should return a TRUE
  value if this redirection is permissible.  The $prospective_request
  will be the request to be sent if this method returns TRUE.
  
  The base implementation will return FALSE unless the method
  is in the object's C<requests_redirectable> list,
  FALSE if the proposed redirection is to a "file://..."
  URL, and TRUE otherwise.
  
  =item $ua->get_basic_credentials( $realm, $uri, $isproxy )
  
  This is called by request() to retrieve credentials for documents
  protected by Basic or Digest Authentication.  The arguments passed in
  is the $realm provided by the server, the $uri requested and a boolean
  flag to indicate if this is authentication against a proxy server.
  
  The method should return a username and password.  It should return an
  empty list to abort the authentication resolution attempt.  Subclasses
  can override this method to prompt the user for the information. An
  example of this can be found in C<lwp-request> program distributed
  with this library.
  
  The base implementation simply checks a set of pre-stored member
  variables, set up with the credentials() method.
  
  =item $ua->progress( $status, $request_or_response )
  
  This is called frequently as the response is received regardless of
  how the content is processed.  The method is called with $status
  "begin" at the start of processing the request and with $state "end"
  before the request method returns.  In between these $status will be
  the fraction of the response currently received or the string "tick"
  if the fraction can't be calculated.
  
  When $status is "begin" the second argument is the request object,
  otherwise it is the response object.
  
  =back
  
  =head1 SEE ALSO
  
  See L<LWP> for a complete overview of libwww-perl5.  See L<lwpcook>
  and the scripts F<lwp-request> and F<lwp-download> for examples of
  usage.
  
  See L<HTTP::Request> and L<HTTP::Response> for a description of the
  message objects dispatched and received.  See L<HTTP::Request::Common>
  and L<HTML::Form> for other ways to build request objects.
  
  See L<WWW::Mechanize> and L<WWW::Search> for examples of more
  specialized user agents based on C<LWP::UserAgent>.
  
  =head1 COPYRIGHT
  
  Copyright 1995-2009 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
LWP_USERAGENT

$fatpacked{"Locale/Maketext/Extract.pm"} = <<'LOCALE_MAKETEXT_EXTRACT';
  package Locale::Maketext::Extract;
  {
    $Locale::Maketext::Extract::VERSION = '0.96';
  }
  
  use strict;
  use Locale::Maketext::Lexicon();
  
  # ABSTRACT: Extract translatable strings from source
  
  
  our %Known_Plugins = (
      perl    => 'Locale::Maketext::Extract::Plugin::Perl',
      yaml    => 'Locale::Maketext::Extract::Plugin::YAML',
      tt2     => 'Locale::Maketext::Extract::Plugin::TT2',
      text    => 'Locale::Maketext::Extract::Plugin::TextTemplate',
      mason   => 'Locale::Maketext::Extract::Plugin::Mason',
      generic => 'Locale::Maketext::Extract::Plugin::Generic',
      formfu  => 'Locale::Maketext::Extract::Plugin::FormFu',
      haml    => 'Locale::Maketext::Extract::Plugin::Haml',
  );
  
  sub new {
      my $class   = shift;
      my %params  = @_;
      my $plugins = delete $params{plugins}
          || { map { $_ => undef } keys %Known_Plugins };
  
      Locale::Maketext::Lexicon::set_option( 'keep_fuzzy' => 1 );
      my $self = bless(
          {   header           => '',
              entries          => {},
              compiled_entries => {},
              lexicon          => {},
              warnings         => 0,
              verbose          => 0,
              wrap             => 0,
              %params,
          },
          $class
      );
      $self->{verbose} ||= 0;
      die "No plugins defined in new()"
          unless $plugins;
      $self->plugins($plugins);
      return $self;
  }
  
  
  sub header { $_[0]{header} || _default_header() }
  sub set_header { $_[0]{header} = $_[1] }
  
  sub lexicon { $_[0]{lexicon} }
  sub set_lexicon { $_[0]{lexicon} = $_[1] || {}; delete $_[0]{lexicon}{''}; }
  
  sub msgstr { $_[0]{lexicon}{ $_[1] } }
  sub set_msgstr { $_[0]{lexicon}{ $_[1] } = $_[2] }
  
  sub entries { $_[0]{entries} }
  sub set_entries { $_[0]{entries} = $_[1] || {} }
  
  sub compiled_entries { $_[0]{compiled_entries} }
  sub set_compiled_entries { $_[0]{compiled_entries} = $_[1] || {} }
  
  sub entry { @{ $_[0]->entries->{ $_[1] } || [] } }
  sub add_entry { push @{ $_[0]->entries->{ $_[1] } }, $_[2] }
  sub del_entry { delete $_[0]->entries->{ $_[1] } }
  
  sub compiled_entry { @{ $_[0]->compiled_entries->{ $_[1] } || [] } }
  sub add_compiled_entry { push @{ $_[0]->compiled_entries->{ $_[1] } }, $_[2] }
  sub del_compiled_entry { delete $_[0]->compiled_entries->{ $_[1] } }
  
  sub plugins {
      my $self = shift;
      if (@_) {
          my @plugins;
          my %params = %{ shift @_ };
  
          foreach my $name ( keys %params ) {
              my $plugin_class = $Known_Plugins{$name} || $name;
              my $filename = $plugin_class . '.pm';
              $filename =~ s/::/\//g;
              local $@;
              eval {
                  require $filename && 1;
                  1;
              } or do {
                  my $error = $@ || 'Unknown';
                  print STDERR "Error loading $plugin_class: $error\n"
                      if $self->{warnings};
                  next;
              };
  
              my $plugin
                  = $params{$name}
                  ? $plugin_class->new( $params{$name} )
                  : $plugin_class->new;
              push @plugins, $plugin;
          }
          $self->{plugins} = \@plugins;
      }
      return $self->{plugins} || [];
  }
  
  sub clear {
      $_[0]->set_header;
      $_[0]->set_lexicon;
      $_[0]->set_comments;
      $_[0]->set_fuzzy;
      $_[0]->set_entries;
      $_[0]->set_compiled_entries;
  }
  
  
  sub read_po {
      my ( $self, $file ) = @_;
      print STDERR "READING PO FILE : $file\n"
          if $self->{verbose};
  
      my $header = '';
  
      local ( *LEXICON, $_ );
      open LEXICON, $file or die $!;
      while (<LEXICON>) {
          ( 1 .. /^$/ ) or last;
          $header .= $_;
      }
      1 while chomp $header;
  
      $self->set_header("$header\n");
  
      require Locale::Maketext::Lexicon::Gettext;
      my $lexicon  = {};
      my $comments = {};
      my $fuzzy    = {};
      $self->set_compiled_entries( {} );
  
      if ( defined($_) ) {
          ( $lexicon, $comments, $fuzzy )
              = Locale::Maketext::Lexicon::Gettext->parse( $_, <LEXICON> );
      }
  
      # Internally the lexicon is in gettext format already.
      $self->set_lexicon( { map _maketext_to_gettext($_), %$lexicon } );
      $self->set_comments($comments);
      $self->set_fuzzy($fuzzy);
  
      close LEXICON;
  }
  
  sub msg_comment {
      my $self    = shift;
      my $msgid   = shift;
      my $comment = $self->{comments}->{$msgid};
      return $comment;
  }
  
  sub msg_fuzzy {
      return $_[0]->{fuzzy}{ $_[1] } ? ', fuzzy' : '';
  }
  
  sub set_comments {
      $_[0]->{comments} = $_[1];
  }
  
  sub set_fuzzy {
      $_[0]->{fuzzy} = $_[1];
  }
  
  
  sub write_po {
      my ( $self, $file, $add_format_marker ) = @_;
      print STDERR "WRITING PO FILE : $file\n"
          if $self->{verbose};
  
      local *LEXICON;
      open LEXICON, ">$file" or die "Can't write to $file$!\n";
  
      print LEXICON $self->header;
  
      foreach my $msgid ( $self->msgids ) {
          $self->normalize_space($msgid);
          print LEXICON "\n";
          if ( my $comment = $self->msg_comment($msgid) ) {
              my @lines = split "\n", $comment;
              print LEXICON map {"# $_\n"} @lines;
          }
          print LEXICON $self->msg_variables($msgid);
          print LEXICON $self->msg_positions($msgid);
          my $flags = $self->msg_fuzzy($msgid);
          $flags .= $self->msg_format($msgid) if $add_format_marker;
          print LEXICON "#$flags\n" if $flags;
          print LEXICON $self->msg_out($msgid);
      }
  
      print STDERR "DONE\n\n"
          if $self->{verbose};
  
  }
  
  
  sub extract {
      my $self    = shift;
      my $file    = shift;
      my $content = shift;
  
      local $@;
  
      my ( @messages, $total, $error_found );
      $total = 0;
      my $verbose = $self->{verbose};
  
      my @plugins = $self->_plugins_specifically_for_file($file);
  
      # If there's no plugin which can handle this file
      # specifically, fall back trying with all known plugins.
      @plugins = @{ $self->plugins } if not @plugins;
  
      foreach my $plugin (@plugins) {
          pos($content) = 0;
          my $success = eval { $plugin->extract($content); 1; };
          if ($success) {
              my $entries = $plugin->entries;
              if ( $verbose > 1 && @$entries ) {
                  push @messages,
                        "     - "
                      . ref($plugin)
                      . ' - Strings extracted : '
                      . ( scalar @$entries );
              }
              for my $entry (@$entries) {
                  my ( $string, $line, $vars ) = @$entry;
                  $self->add_entry( $string => [ $file, $line, $vars ] );
                  if ( $verbose > 2 ) {
                      $vars = '' if !defined $vars;
  
                      # pad string
                      $string =~ s/\n/\n               /g;
                      push @messages,
                          sprintf(
                          qq[       - %-8s "%s" (%s)],
                          $line . ':',
                          $string, $vars
                          ),
                          ;
                  }
              }
              $total += @$entries;
          }
          else {
              $error_found++;
              if ( $self->{warnings} ) {
                  push @messages,
                        "Error parsing '$file' with plugin "
                      . ( ref $plugin )
                      . ": \n $@\n";
              }
          }
          $plugin->clear;
      }
  
      print STDERR " * $file\n   - Total strings extracted : $total"
          . ( $error_found ? ' [ERROR ] ' : '' ) . "\n"
          if $verbose
          && ( $total || $error_found );
      print STDERR join( "\n", @messages ) . "\n"
          if @messages;
  
  }
  
  sub extract_file {
      my ( $self, $file ) = @_;
  
      local ( $/, *FH );
      open FH, $file or die "Error reading from file '$file' : $!";
      my $content = scalar <FH>;
  
      $self->extract( $file => $content );
      close FH;
  }
  
  
  sub compile {
      my ( $self, $entries_are_in_gettext_style ) = @_;
      my $entries = $self->entries;
      my $lexicon = $self->lexicon;
      my $comp    = $self->compiled_entries;
  
      while ( my ( $k, $v ) = each %$entries ) {
          my $compiled_key = (
              ($entries_are_in_gettext_style)
              ? $k
              : _maketext_to_gettext($k)
          );
          $comp->{$compiled_key}    = $v;
          $lexicon->{$compiled_key} = ''
              unless exists $lexicon->{$compiled_key};
      }
  
      return %$lexicon;
  }
  
  
  my %Escapes = map { ( "\\$_" => eval("qq(\\$_)") ) } qw(t r f b a e);
  
  sub normalize_space {
      my ( $self, $msgid ) = @_;
      my $nospace = $msgid;
      $nospace =~ s/ +$//;
  
      return
          unless ( !$self->has_msgid($msgid) and $self->has_msgid($nospace) );
  
      $self->set_msgstr( $msgid => $self->msgstr($nospace)
              . ( ' ' x ( length($msgid) - length($nospace) ) ) );
  }
  
  
  sub msgids { sort keys %{ $_[0]{lexicon} } }
  
  sub has_msgid {
      my $msg_str = $_[0]->msgstr( $_[1] );
      return defined $msg_str ? length $msg_str : 0;
  }
  
  sub msg_positions {
      my ( $self, $msgid ) = @_;
      my %files = ( map { ( " $_->[0]:$_->[1]" => 1 ) }
              $self->compiled_entry($msgid) );
      return $self->{wrap}
          ? join( "\n", ( map { '#:' . $_ } sort( keys %files ) ), '' )
          : join( '', '#:', sort( keys %files ), "\n" );
  }
  
  sub msg_variables {
      my ( $self, $msgid ) = @_;
      my $out = '';
  
      my %seen;
      foreach my $entry ( grep { $_->[2] } $self->compiled_entry($msgid) ) {
          my ( $file, $line, $var ) = @$entry;
          $var =~ s/^\s*,\s*//;
          $var =~ s/\s*$//;
          $out .= "#. ($var)\n" unless !length($var) or $seen{$var}++;
      }
  
      return $out;
  }
  
  sub msg_format {
      my ( $self, $msgid ) = @_;
      return ", perl-maketext-format"
          if $msgid =~ /%(?:[1-9]\d*|\w+\([^\)]*\))/;
      return '';
  }
  
  sub msg_out {
      my ( $self, $msgid ) = @_;
      my $msgstr = $self->msgstr($msgid);
  
      return "msgid " . _format($msgid) . "msgstr " . _format($msgstr);
  }
  
  
  sub _default_header {
      return << '.';
  # SOME DESCRIPTIVE TITLE.
  # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER
  # This file is distributed under the same license as the PACKAGE package.
  # FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.
  #
  #, fuzzy
  msgid ""
  msgstr ""
  "Project-Id-Version: PACKAGE VERSION\n"
  "POT-Creation-Date: YEAR-MO-DA HO:MI+ZONE\n"
  "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
  "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
  "Language-Team: LANGUAGE <LL@li.org>\n"
  "MIME-Version: 1.0\n"
  "Content-Type: text/plain; charset=CHARSET\n"
  "Content-Transfer-Encoding: 8bit\n"
  .
  }
  
  sub _maketext_to_gettext {
      my $text = shift;
      return '' unless defined $text;
  
      $text =~ s{((?<!~)(?:~~)*)\[_([1-9]\d*|\*)\]}
                {$1%$2}g;
      $text =~ s{((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]}
                {"$1%$2(" . _escape($3) . ')'}eg;
  
      $text =~ s/~([\~\[\]])/$1/g;
      return $text;
  }
  
  sub _escape {
      my $text = shift;
      $text =~ s/\b_([1-9]\d*)/%$1/g;
      return $text;
  }
  
  sub _format {
      my $str = shift;
  
      $str =~ s/(?=[\\"])/\\/g;
  
      while ( my ( $char, $esc ) = each %Escapes ) {
          $str =~ s/$esc/$char/g;
      }
  
      return "\"$str\"\n" unless $str =~ /\n/;
      my $multi_line = ( $str =~ /\n(?!\z)/ );
      $str =~ s/\n/\\n"\n"/g;
      if ( $str =~ /\n"$/ ) {
          chop $str;
      }
      else {
          $str .= "\"\n";
      }
      return $multi_line ? qq(""\n"$str) : qq("$str);
  }
  
  sub _plugins_specifically_for_file {
      my ( $self, $file ) = @_;
  
      return () if not $file;
  
      my @plugins = grep {
          my $plugin     = $_;
          my @file_types = $plugin->file_types;
          my $is_generic
              = ( scalar @file_types == 1 and $file_types[0] eq '*' );
          ( not $is_generic and $plugin->known_file_type($file) );
      } @{ $self->plugins };
  
      return @plugins;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract - Extract translatable strings from source
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      my $Ext = Locale::Maketext::Extract->new;
      $Ext->read_po('messages.po');
      $Ext->extract_file($_) for <*.pl>;
  
      # Set $entries_are_in_gettext_format if the .pl files above use
      # loc('%1') instead of loc('[_1]')
      $Ext->compile($entries_are_in_gettext_format);
  
      $Ext->write_po('messages.po');
  
      -----------------------------------
  
      ### Specifying parser plugins ###
  
      my $Ext = Locale::Maketext::Extract->new(
  
          # Specify which parser plugins to use
          plugins => {
  
              # Use Perl parser, process files with extension .pl .pm .cgi
              perl => [],
  
              # Use YAML parser, process all files
              yaml => ['*'],
  
              # Use TT2 parser, process files with extension .tt2 .tt .html
              # or which match the regex
              tt2  => [
                  'tt2',
                  'tt',
                  'html',
                  qr/\.tt2?\./
              ],
  
              # Use My::Module as a parser for all files
              'My::Module' => ['*'],
  
          },
  
          # Warn if a parser can't process a file or problems loading a plugin
          warnings => 1,
  
          # List processed files
          verbose => 1,
  
      );
  
  =head1 DESCRIPTION
  
  This module can extract translatable strings from files, and write
  them back to PO files.  It can also parse existing PO files and merge
  their contents with newly extracted strings.
  
  A command-line utility, L<xgettext.pl>, is installed with this module
  as well.
  
  The format parsers are loaded as plugins, so it is possible to define
  your own parsers.
  
  Following formats of input files are supported:
  
  =over 4
  
  =item Perl source files  (plugin: perl)
  
  Valid localization function names are: C<translate>, C<maketext>,
  C<gettext>, C<l>, C<loc>, C<x>, C<_> and C<__>.
  
  For a slightly more accurate, but much slower Perl parser, you can  use the PPI
  plugin. This does not have a short name (like C<perl>), but must be specified
  in full.
  
  =item HTML::Mason (Mason 1) and Mason (Mason 2) (plugin: mason)
  
  HTML::Mason (aka Mason 1)
   Strings inside <&|/l>...</&> and <&|/loc>...</&> are extracted.
  
  Mason (aka Mason 2)
  Strings inside <% $.floc { %>...</%> or <% $.fl { %>...</%> or
  <% $self->floc { %>...</%> or <% $self->fl { %>...</%> are extracted.
  
  =item Template Toolkit (plugin: tt2)
  
  Valid forms are:
  
    [% | l(arg1,argn) %]string[% END %]
    [% 'string' | l(arg1,argn) %]
    [% l('string',arg1,argn) %]
  
    FILTER and | are interchangeable
    l and loc are interchangeable
    args are optional
  
  =item Text::Template (plugin: text)
  
  Sentences between C<STARTxxx> and C<ENDxxx> are extracted individually.
  
  =item YAML (plugin: yaml)
  
  Valid forms are _"string" or _'string', eg:
  
      title: _"My title"
      desc:  _'My "quoted" string'
  
  Quotes do not have to be escaped, so you could also do:
  
      desc:  _"My "quoted" string"
  
  =item HTML::FormFu (plugin: formfu)
  
  HTML::FormFu uses a config-file to generate forms, with built in
  support for localizing errors, labels etc.
  
  We extract the text after C<_loc: >:
      content_loc: this is the string
      message_loc: ['Max string length: [_1]', 10]
  
  =item Generic Template (plugin: generic)
  
  Strings inside {{...}} are extracted.
  
  =back
  
  =head1 METHODS
  
  =head2 Constructor
  
      new()
  
      new(
          plugins   => {...},
          warnings  => 1 | 0,
          verbose   => 0 | 1 | 2 | 3,
      )
  
  See L</"Plugins">, L</"Warnings"> and L</"Verbose"> for details
  
  =head2 Plugins
  
      $ext->plugins({...});
  
  Locale::Maketext::Extract uses plugins (see below for the list)
  to parse different formats.
  
  Each plugin can also specify which file types it can parse.
  
      # use only the YAML plugin
      # only parse files with the default extension list defined in the plugin
      # ie .yaml .yml .conf
  
      $ext->plugins({
          yaml => [],
      })
  
  
      # use only the Perl plugin
      # parse all file types
  
      $ext->plugins({
          perl => '*'
      })
  
      $ext->plugins({
          tt2  => [
              'tt',              # matches base filename against /\.tt$/
              qr/\.tt2?\./,      # matches base filename against regex
              \&my_filter,       # codref called
          ]
      })
  
      sub my_filter {
          my ($base_filename,$path_to_file) = @_;
  
          return 1 | 0;
      }
  
      # Specify your own parser
      # only parse files with the default extension list defined in the plugin
  
      $ext->plugins({
          'My::Extract::Parser'  => []
      })
  
  By default, if no plugins are specified, it first tries to determine which
  plugins are intended specifically for the file type and uses them. If no
  such plugins are found, it then uses all of the builtin plugins, overriding
  the file types specified in each.
  
  =head3 Available plugins
  
  =over 4
  
  =item C<perl>    : L<Locale::Maketext::Extract::Plugin::Perl>
  
  For a slightly more accurate but much slower Perl parser, you can use
  the PPI plugin. This does not have a short name, but must be specified in
  full, ie: L<Locale::Maketext::Extract::Plugin::PPI>
  
  =item C<tt2>     : L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item C<yaml>    : L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item C<formfu>  : L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item C<mason>   : L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item C<text>    : L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item C<generic> : L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  Also, see L<Locale::Maketext::Extract::Plugin::Base> for details of how to
  write your own plugin.
  
  =head2 Warnings
  
  Because the YAML and TT2 plugins use proper parsers, rather than just regexes,
  if a source file is not valid and it is unable to parse the file, then the
  parser will throw an error and abort parsing.
  
  The next enabled plugin will be tried.
  
  By default, you will not see these errors.  If you would like to see them,
  then enable warnings via new(). All parse errors will be printed to STDERR.
  
  Also, if developing your own plugin, turn on warnings to see any errors that
  result from loading your plugin.
  
  =head2 Verbose
  
  If you would like to see which files have been processed, which plugins were
  used, and which strings were extracted, then enable C<verbose>. If no
  acceptable plugin was found, or no strings were extracted, then the file
  is not listed:
  
        $ext = Locale::Extract->new( verbose => 1 | 2 | 3);
  
     OR
        xgettext.pl ... -v           # files reported
        xgettext.pl ... -v -v        # files and plugins reported
        xgettext.pl ... -v -v -v     # files, plugins and strings reported
  
  =head2 Accessors
  
      header, set_header
      lexicon, set_lexicon, msgstr, set_msgstr
      entries, set_entries, entry, add_entry, del_entry
      compiled_entries, set_compiled_entries, compiled_entry,
      add_compiled_entry, del_compiled_entry
      clear
  
  =head2 PO File manipulation
  
  =head3 method read_po ($file)
  
  =head3 method write_po ($file, $add_format_marker?)
  
  =head2 Extraction
  
      extract
      extract_file
  
  =head2 Compilation
  
  =head3 compile($entries_are_in_gettext_style?)
  
  Merges the C<entries> into C<compiled_entries>.
  
  If C<$entries_are_in_gettext_style> is true, the previously extracted entries
  are assumed to be in the B<Gettext> style (e.g. C<%1>).
  
  Otherwise they are assumed to be in B<Maketext> style (e.g. C<[_1]>) and are
  converted into B<Gettext> style before merging into C<compiled_entries>.
  
  The C<entries> are I<not> cleared after each compilation; use
  C<->set_entries()> to clear them if you need to extract from sources with
  varying styles.
  
  =head3 normalize_space
  
  =head2 Lexicon accessors
  
      msgids, has_msgid,
      msgstr, set_msgstr
      msg_positions, msg_variables, msg_format, msg_out
  
  =head2 Internal utilities
  
      _default_header
      _maketext_to_gettext
      _escape
      _format
      _plugins_specifically_for_file
  
  =head1 ACKNOWLEDGMENTS
  
  Thanks to Jesse Vincent for contributing to an early version of this
  module.
  
  Also to Alain Barbet, who effectively re-wrote the source parser with a
  flex-like algorithm.
  
  =head1 SEE ALSO
  
  L<xgettext.pl>, L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2003-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT

$fatpacked{"Locale/Maketext/Extract/Plugin/Base.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_BASE';
  package Locale::Maketext::Extract::Plugin::Base;
  {
    $Locale::Maketext::Extract::Plugin::Base::VERSION = '0.96';
  }
  
  use strict;
  
  use File::Basename qw(fileparse);
  
  # ABSTRACT: Base module for format parser plugins
  
  
  sub new {
      my $class = shift;
      my $self = bless { entries => [], }, $class;
  
      $self->_compile_file_types(@_);
      return $self;
  }
  
  
  sub add_entry {
      my $self = shift;
      push @{ $self->{entries} }, [@_];
  }
  
  
  #===================================
  sub entries {
  #===================================
      my $self = shift;
      return $self->{entries};
  }
  
  
  #===================================
  sub clear {
  #===================================
      my $self = shift;
      $self->{entries} = [];
  }
  
  
  sub file_types {
      die "Please override sub file_types() to return "
          . "a list of recognised file extensions, or regexes";
  }
  
  
  sub extract {
      die "Please override sub extract()";
  }
  
  sub _compile_file_types {
      my $self = shift;
      my @file_types
          = ref $_[0] eq 'ARRAY'
          ? @{ shift @_ }
          : @_;
      @file_types = $self->file_types
          unless @file_types;
  
      my @checks;
      if ( grep { $_ eq '*' } @file_types ) {
          $self->{file_checks} = [ sub {1} ];
          return;
      }
      foreach my $type (@file_types) {
          if ( ref $type eq 'CODE' ) {
              push @checks, $type;
              next;
          }
          else {
              my $regex
                  = ref $type
                  ? $type
                  : qr/^.*\.\Q$type\E$/;
              push @checks, sub { $_[0] =~ m/$regex/ };
          }
      }
      $self->{file_checks} = \@checks;
  }
  
  
  sub known_file_type {
      my $self = shift;
      my ( $name, $path ) = fileparse( shift @_ );
      foreach my $check ( @{ $self->{file_checks} } ) {
          return 1 if $check->( $name, $path );
      }
      return 0;
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Base - Base module for format parser plugins
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      package My::Parser::Plugin;
      use base qw(Locale::Maketext::Extract::Plugin::Base);
  
      sub file_types {
          return [qw( ext ext2 )]
      }
  
      sub extract {
          my $self = shift;
          local $_ = shift;
  
          my $line = 1;
  
          while (my $found = $self->routine_to_extract_strings) {
              $self->add_entry($str,[$filename,$line,$vars])
          }
  
          return;
      }
  
  =head1 DESCRIPTION
  
  All format parser plugins in Locale::Maketext::Extract inherit from
  Locale::Maketext::Extract::Plugin::Base.
  
  If you want to write your own custom parser plugin, you will need to inherit
  from this module, and provide C<file_types()> and C<extract()> methods,
  as shown above.
  
  =head1 METHODS
  
  =over 4
  
  =item new()
  
      $plugin = My::Parser->new(
          @file_types         # Optionally specify a list of recognised file types
      )
  
  =item add_entry()
  
      $plugin->add_entry($str,$line,$vars)
  
  =item C<entries()>
  
      $entries = $plugin->entries;
  
  =item C<clear()>
  
      $plugin->clear
  
  Clears all stored entries.
  
  =item file_types()
  
      @default_file_types = $plugin->file_types
  
  Returns a list of recognised file types that your module knows how to parse.
  
  Each file type can be one of:
  
  =over 4
  
  =item * A plain string
  
     'pl'  => base filename is matched against qr/\.pl$/
     '*'   => all files are accepted
  
  =item * A regex
  
     qr/\.tt2?\./ => base filename is matched against this regex
  
  =item * A codref
  
      sub {}  => this codref is called as $coderef->($base_filename,$path_to_file)
                 It should return true or false
  
  =back
  
  =item extract()
  
      $plugin->extract($filecontents);
  
  extract() is the method that will be called to process the contents of the
  current file.
  
  When it finds a string that should be extracted, it should call
  
     $self->add_entry($string,$line,$vars])
  
  where C<$vars> refers to any arguments that are being passed to the localise
  function. For instance:
  
     l("You found [quant,_1,file,files]",files_found)
  
       string: "You found [quant,_1,file,files]"
       vars  : (files_found)
  
  IMPORTANT: a single plugin instance is used for all files, so if you plan
  on storing state information in the C<$plugin> object, this should be cleared
  out at the beginning of C<extract()>
  
  =item known_file_type()
  
      if ($plugin->known_file_type($filename_with_path)) {
          ....
      }
  
  Determines whether the current file should be handled by this parser, based
  either on the list of file_types specified when this object was created,
  or the default file_types specified in the module.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::PPI>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Clinton Gormley [DRTECH] E<lt>clinton@traveljury.comE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_BASE

$fatpacked{"Locale/Maketext/Extract/Plugin/FormFu.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_FORMFU';
  package Locale::Maketext::Extract::Plugin::FormFu;
  {
    $Locale::Maketext::Extract::Plugin::FormFu::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  # ABSTRACT: FormFu format parser
  
  
  sub file_types {
      return qw( yaml yml conf );
  }
  
  sub extract {
      my $self = shift;
      my $data = shift;
  
      my $y = Locale::Maketext::Extract::Plugin::FormFu::Extractor->new();
      $y->load($data);
  
      foreach my $entry ( @{ $y->found } ) {
          $self->add_entry(@$entry);
      }
  
  }
  
  package Locale::Maketext::Extract::Plugin::FormFu::Extractor;
  {
    $Locale::Maketext::Extract::Plugin::FormFu::Extractor::VERSION = '0.96';
  }
  
  use base qw(YAML::Loader);
  
  #===================================
  sub new {
  #===================================
      my $class = shift;
      my $self  = $class->SUPER::new(@_);
      $self->{found} = [];
      return $self;
  }
  
  #===================================
  sub _check_key {
  #===================================
      my $self = shift;
      my ( $key, $value, $line ) = @_;
      my ( $str, $vars );
      if ( ref $value ) {
          return if ref $value ne 'ARRAY';
          $str = shift @$value;
          $vars = join( ', ', @$value );
      }
      else {
          $str = $value;
      }
      return
             unless $key
          && $key =~ /_loc$/
          && defined $str;
      push @{ $self->{found} }, [ $str, $line, $vars ];
  }
  
  #===================================
  sub _parse_mapping {
  #===================================
      my $self     = shift;
      my ($anchor) = @_;
      my $mapping  = {};
      $self->anchor2node->{$anchor} = $mapping;
      my $key;
      while ( not $self->done
          and $self->indent == $self->offset->[ $self->level ] )
      {
  
          # If structured key:
          if ( $self->{content} =~ s/^\?\s*// ) {
              $self->preface( $self->content );
              $self->_parse_next_line(YAML::Loader::COLLECTION);
              $key = $self->_parse_node();
              $key = "$key";
          }
  
          # If "default" key (equals sign)
          elsif ( $self->{content} =~ s/^\=\s*// ) {
              $key = YAML::Loader::VALUE;
          }
  
          # If "comment" key (slash slash)
          elsif ( $self->{content} =~ s/^\=\s*// ) {
              $key = YAML::Loader::COMMENT;
          }
  
          # Regular scalar key:
          else {
              $self->inline( $self->content );
              $key = $self->_parse_inline();
              $key = "$key";
              $self->content( $self->inline );
              $self->inline('');
          }
  
          unless ( $self->{content} =~ s/^:\s*// ) {
              $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
          }
          $self->preface( $self->content );
          my $line = $self->line;
          $self->_parse_next_line(YAML::Loader::COLLECTION);
          my $value = $self->_parse_node();
          if ( exists $mapping->{$key} ) {
              $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
          }
          else {
              $mapping->{$key} = $value;
              $self->_check_key( $key, $value, $line );
          }
      }
      return $mapping;
  }
  
  #===================================
  sub _parse_inline_mapping {
  #===================================
      my $self       = shift;
      my ($anchor)   = @_;
      my $node       = {};
      my $start_line = $self->{_start_line};
  
      $self->anchor2node->{$anchor} = $node;
  
      $self->die('YAML_PARSE_ERR_INLINE_MAP')
          unless $self->{inline} =~ s/^\{\s*//;
      while ( not $self->{inline} =~ s/^\s*\}// ) {
          my $key = $self->_parse_inline();
          $self->die('YAML_PARSE_ERR_INLINE_MAP')
              unless $self->{inline} =~ s/^\: \s*//;
          my $value = $self->_parse_inline();
          if ( exists $node->{$key} ) {
              $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
          }
          else {
              $node->{$key} = $value;
              $self->_check_key( $key, $value, $start_line );
          }
          next if $self->inline =~ /^\s*\}/;
          $self->die('YAML_PARSE_ERR_INLINE_MAP')
              unless $self->{inline} =~ s/^\,\s*//;
      }
      return $node;
  }
  
  #===================================
  sub _parse_next_line {
  #===================================
      my $self = shift;
      $self->{_start_line} = $self->line;
      $self->SUPER::_parse_next_line(@_);
  }
  
  #===================================
  sub found {
  #===================================
      my $self = shift;
      return $self->{found};
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::FormFu - FormFu format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::FormFu->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  HTML::FormFu uses a config-file to generate forms, with built in support
  for localizing errors, labels etc.
  
  =head1 SHORT PLUGIN NAME
  
      formfu
  
  =head1 VALID FORMATS
  
  We extract the text after any key which ends in C<_loc>:
  
      content_loc: this is the string
      message_loc: ['Max length [_1]', 10]
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .yaml
  
  =item .yml
  
  =item .conf
  
  =back
  
  =head1 REQUIRES
  
  L<YAML>
  
  =head1 NOTES
  
  The docs for the YAML module describes it as alpha code. It is not as tolerant
  of errors as L<YAML::Syck>. However, because it is pure Perl, it is easy
  to hook into.
  
  I have seen it enter endless loops, so if xgettext.pl hangs, try running it
  again with C<--verbose --verbose> (twice) enabled, so that you can see if
  the fault lies with YAML.  If it does, either correct the YAML source file,
  or use the file_types to exclude that file.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<YAML>
  
  =item L<HTML::FormFu>
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Clinton Gormley E<lt>clint@traveljury.comE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_FORMFU

$fatpacked{"Locale/Maketext/Extract/Plugin/Generic.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_GENERIC';
  package Locale::Maketext::Extract::Plugin::Generic;
  {
    $Locale::Maketext::Extract::Plugin::Generic::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  # ABSTRACT: Generic template parser
  
  
  sub file_types {
      return qw( * );
  }
  
  sub extract {
      my $self = shift;
      local $_ = shift;
  
      my $line = 1;
  
      # Generic Template:
      $line = 1;
      pos($_) = 0;
      while (m/\G(.*?(?<!\{)\{\{(?!\{)(.*?)\}\})/sg) {
          my ( $vars, $str ) = ( '', $2 );
          $line += ( () = ( $1 =~ /\n/g ) );    # cryptocontext!
          $self->add_entry( $str, $line, $vars );
      }
  
      my $quoted
          = '(\')([^\\\']*(?:\\.[^\\\']*)*)(\')|(\")([^\\\"]*(?:\\.[^\\\"]*)*)(\")';
  
      # Comment-based mark: "..." # loc
      $line = 1;
      pos($_) = 0;
      while (m/\G(.*?($quoted)[\}\)\],;]*\s*\#\s*loc\s*$)/smog) {
          my $str = substr( $2, 1, -1 );
          $line += ( () = ( $1 =~ /\n/g ) );    # cryptocontext!
          $str =~ s/\\(["'])/$1/g;
          $self->add_entry( $str, $line, '' );
      }
  
      # Comment-based pair mark: "..." => "..." # loc_pair
      $line = 1;
      pos($_) = 0;
      while (m/\G(.*?(\w+)\s*=>\s*($quoted)[\}\)\],;]*\s*\#\s*loc_pair\s*$)/smg)
      {
          my $key = $2;
          my $val = substr( $3, 1, -1 );
          $line += ( () = ( $1 =~ /\n/g ) );    # cryptocontext!
          $key =~ s/\\(["'])/$1/g;
          $val =~ s/\\(["'])/$1/g;
          $self->add_entry( $val, $line, '' );
      }
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Generic - Generic template parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::Generic->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise from generic templates.
  
  =head1 SHORT PLUGIN NAME
  
      generic
  
  =head1 VALID FORMATS
  
  Strings inside {{...}} are extracted.
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item All file types
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =back
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_GENERIC

$fatpacked{"Locale/Maketext/Extract/Plugin/Haml.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_HAML';
  package Locale::Maketext::Extract::Plugin::Haml;
  {
    $Locale::Maketext::Extract::Plugin::Haml::VERSION = '0.96';
  }
  
  use strict;
  use warnings;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  use Text::Haml;
  use Locale::Maketext::Extract::Plugin::Perl;
  
  # ABSTRACT: HAML format parser
  
  
  sub file_types {
      return qw( haml );
  }
  
  sub extract {
      my $self    = shift;
      my $content = shift;
  
      my $haml = Text::Haml->new;
      $haml->parse($content);
  
      # Checking for expr and text allows us to recognise
      # the types of HTML entries we are interested in.
      my @texts = map { $_->{text} }
        grep { $_->{text} and ( $_->{expr} or $_->{type} eq 'block') }
            @{ $haml->tape };
  
      my $perl = Locale::Maketext::Extract::Plugin::Perl->new;
  
      # Calling extract on our strings will cause
      # EPPerl to store our entries internally.
      map { $perl->extract($_) } @texts;
  
      map { $self->add_entry( @{$_} ) } @{ $perl->entries };
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Haml - HAML format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::Haml->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise from HAML files.
  
  =head1 SHORT PLUGIN NAME
  
      haml
  
  =head1 VALID FORMATS
  
  Extracts strings in the same way as Locale::Maketext::Extract::Plugin::Perl,
  but only ones within "text" components of HAML files.
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .haml
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  Calum Halcrow E<lt>cpan@calumhalcrow.comE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_HAML

$fatpacked{"Locale/Maketext/Extract/Plugin/Mason.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_MASON';
  package Locale::Maketext::Extract::Plugin::Mason;
  {
    $Locale::Maketext::Extract::Plugin::Mason::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  # ABSTRACT: HTML::Mason (aka Mason 1) and Mason (aka Mason 2) format parser
  
  
  sub file_types {
      return qw( * );
  }
  
  sub extract {
      my $self = shift;
      local $_ = shift;
  
      my $line = 1;
  
      # HTML::Mason (aka Mason 1)
      while (m!\G(.*?<&\|[ ]*/l(?:oc)?(?:[ ]*,[ ]*(.*?))?[ ]*&>(.*?)</&>)!sg) {
          my ( $vars, $str ) = ( $2, $3 );
          $line += ( () = ( $1 =~ /\n/g ) );    # cryptocontext!
          $self->add_entry( $str, $line, $vars );
      }
  
      # Mason (aka Mason 2)
      while (
          m!\G(.*?<%[ ]*(?:\$(?:\.|self->))fl(?:oc)?(?:[ ]*\((.*?)\))?[ ]*{[ ]*%>(.*?)</%>)!sg
          )
      {
          my ( $vars, $str ) = ( $2, $3 );
          $line += ( () = ( $1 =~ /\n/g ) );    # cryptocontext!
          $self->add_entry( $str, $line, $vars );
      }
  
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Mason - HTML::Mason (aka Mason 1) and Mason (aka Mason 2) format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::Mason->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise from Mason files.
  
  =head1 SHORT PLUGIN NAME
  
      mason
  
  =head1 VALID FORMATS
  
  HTML::Mason (aka Mason 1)
   Strings inside <&|/l>...</&> and <&|/loc>...</&> are extracted.
  
  Mason (aka Mason 2)
  Strings inside <% $.floc { %>...</%> or <% $.fl { %>...</%> or
  <% $self->floc { %>...</%> or <% $self->fl { %>...</%> are extracted.
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item All file types
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_MASON

$fatpacked{"Locale/Maketext/Extract/Plugin/PPI.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_PPI';
  package Locale::Maketext::Extract::Plugin::PPI;
  {
    $Locale::Maketext::Extract::Plugin::PPI::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  use PPI();
  
  # ABSTRACT: Perl format parser
  
  
  sub file_types {
      return qw( pm pl cgi );
  }
  
  my %subnames = map { $_ => 1 } qw (translate maketext gettext l loc x __);
  
  #===================================
  sub extract {
  #===================================
      my $self = shift;
      my $text = shift;
  
      my $doc = PPI::Document->new( \$text, index_locations => 1 );
  
      foreach my $statement ( @{ $doc->find('PPI::Statement') } ) {
          my @children = $statement->schildren;
  
          while ( my $child = shift @children ) {
              next
                  unless @children
                  && ( $child->isa('PPI::Token::Word')
                  && $subnames{ $child->content }
                  || $child->isa('PPI::Token::Magic')
                  && $child->content eq '_' );
  
              my $list = shift @children;
              next
                  unless $list->isa('PPI::Structure::List')
                  && $list->schildren;
  
              $self->_check_arg_list($list);
          }
      }
  }
  
  #===================================
  sub _check_arg_list {
  #===================================
      my $self = shift;
      my $list = shift;
      my @args = ( $list->schildren )[0]->schildren;
  
      my $final_string = '';
      my ( $line, $mode );
  
      while ( my $string_el = shift @args ) {
          return
              unless $string_el->isa('PPI::Token::Quote')
              || $string_el->isa('PPI::Token::HereDoc');
          $line ||= $string_el->location->[0];
          my $string;
          if ( $string_el->isa('PPI::Token::HereDoc') ) {
              $string = join( '', $string_el->heredoc );
              $mode
                  = $string_el->{_mode} eq 'interpolate'
                  ? 'double'
                  : 'literal';
          }
          else {
              $string = $string_el->string;
              $mode
                  = $string_el->isa('PPI::Token::Quote::Literal') ? 'literal'
                  : (    $string_el->isa('PPI::Token::Quote::Double')
                      || $string_el->isa('PPI::Token::Quote::Interpolate') )
                  ? 'double'
                  : 'single';
          }
  
          if ( $mode eq 'double' ) {
              return
                  if !!( $string =~ /(?<!\\)(?:\\\\)*[\$\@]/ );
              $string = eval qq("$string");
          }
          elsif ( $mode eq 'single' ) {
              $string =~ s/\\'/'/g;
          }
  
          #    $string =~ s/(?<!\\)\\//g;
          $string =~ s/\\\\/\\/g;
  
          #        unless $mode eq 'literal';
  
          $final_string .= $string;
  
          my $next_op = shift @args;
          last
              unless $next_op
              && $next_op->isa('PPI::Token::Operator')
              && $next_op->content eq '.';
      }
      return unless $final_string;
  
      my $vars = join( '', map { $_->content } @args );
      $self->add_entry( $final_string, $line, $vars );
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::PPI - Perl format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::PPI->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Does exactly the same thing as the L<Locale::Maketext::Extract::Plugin::Perl>
  parser, but more accurately, and more slowly. Considerably more slowly! For this
  reason it isn't a built-in plugin.
  
  =head1 SHORT PLUGIN NAME
  
      none - the module must be specified in full
  
  =head1 VALID FORMATS
  
  Valid localization function names are:
  
  =over 4
  
  =item translate
  
  =item maketext
  
  =item gettext
  
  =item l
  
  =item loc
  
  =item x
  
  =item _
  
  =item __
  
  =back
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .pm
  
  =item .pl
  
  =item .cgi
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_PPI

$fatpacked{"Locale/Maketext/Extract/Plugin/Perl.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_PERL';
  package Locale::Maketext::Extract::Plugin::Perl;
  {
    $Locale::Maketext::Extract::Plugin::Perl::VERSION = '0.96';
  }
  
  use strict;
  
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  # ABSTRACT: Perl format parser
  
  
  use constant NUL  => 0;
  use constant BEG  => 1;
  use constant PAR  => 2;
  use constant HERE => 10;
  use constant QUO1 => 3;
  use constant QUO2 => 4;
  use constant QUO3 => 5;
  use constant QUO4 => 6;
  use constant QUO5 => 7;
  use constant QUO6 => 8;
  use constant QUO7 => 9;
  
  sub file_types {
      return qw( pm pl cgi );
  }
  
  sub extract {
      my $self = shift;
      local $_ = shift;
  
      local $SIG{__WARN__} = sub { die @_ };
  
      # Perl code:
      my ( $state, $line_offset, $str, $str_part, $vars, $quo, $heredoc )
          = ( 0, 0 );
      my $orig = 1 + ( () = ( ( my $__ = $_ ) =~ /\n/g ) );
  
  PARSER: {
          $_ = substr( $_, pos($_) ) if ( pos($_) );
          my $line = $orig - ( () = ( ( my $__ = $_ ) =~ /\n/g ) );
  
          # various ways to spell the localization function
          $state == NUL
              && m/\b(translate|maketext|gettext|__?|loc(?:ali[sz]e)?|l|x)/gc
              && do { $state = BEG; redo };
          $state == BEG && m/^([\s\t\n]*)/gc && redo;
  
          # begin ()
          $state == BEG
              && m/^([\S\(])\s*/gc
              && do { $state = ( ( $1 eq '(' ) ? PAR : NUL ); redo };
  
          # concat
          $state == PAR
              && defined($str)
              && m/^(\s*\.\s*)/gc
              && do { $line_offset += ( () = ( ( my $__ = $1 ) =~ /\n/g ) ); redo };
  
          # str_part
          $state == PAR && defined($str_part) && do {
              if ( ( $quo == QUO1 ) || ( $quo == QUO5 ) ) {
                  $str_part =~ s/\\([\\'])/$1/g
                      if ($str_part);    # normalize q strings
              }
              elsif ( $quo != QUO6 ) {
                  $str_part =~ s/(\\(?:[0x]..|c?.))/"qq($1)"/eeg
                      if ($str_part);    # normalize qq / qx strings
              }
              $str .= $str_part;
              undef $str_part;
              undef $quo;
              redo;
          };
  
          # begin or end of string
          $state == PAR && m/^(\')/gc && do { $state = $quo = QUO1; redo };
          $state == QUO1 && m/^([^'\\]+)/gc   && do { $str_part .= $1; redo };
          $state == QUO1 && m/^((?:\\.)+)/gcs && do { $str_part .= $1; redo };
          $state == QUO1 && m/^\'/gc && do { $state = PAR; redo };
  
          $state == PAR && m/^\"/gc && do { $state = $quo = QUO2; redo };
          $state == QUO2 && m/^([^"\\]+)/gc   && do { $str_part .= $1; redo };
          $state == QUO2 && m/^((?:\\.)+)/gcs && do { $str_part .= $1; redo };
          $state == QUO2 && m/^\"/gc && do { $state = PAR; redo };
  
          $state == PAR && m/^\`/gc && do { $state = $quo = QUO3; redo };
          $state == QUO3 && m/^([^\`]*)/gc && do { $str_part .= $1; redo };
          $state == QUO3 && m/^\`/gc && do { $state = PAR; redo };
  
          $state == PAR && m/^qq\{/gc && do { $state = $quo = QUO4; redo };
          $state == QUO4 && m/^([^\}]*)/gc && do { $str_part .= $1; redo };
          $state == QUO4 && m/^\}/gc && do { $state = PAR; redo };
  
          $state == PAR && m/^q\{/gc && do { $state = $quo = QUO5; redo };
          $state == QUO5 && m/^([^\}]*)/gc && do { $str_part .= $1; redo };
          $state == QUO5 && m/^\}/gc && do { $state = PAR; redo };
  
          # find heredoc terminator, then get the
          #heredoc and go back to current position
          $state == PAR
              && m/^<<\s*\'/gc
              && do { $state = $quo = QUO6; $heredoc = ''; redo };
          $state == QUO6 && m/^([^'\\\n]+)/gc && do { $heredoc .= $1; redo };
          $state == QUO6 && m/^((?:\\.)+)/gc  && do { $heredoc .= $1; redo };
          $state == QUO6
              && m/^\'/gc
              && do { $state = HERE; $heredoc =~ s/\\\'/\'/g; redo };
  
          $state == PAR
              && m/^<<\s*\"/gc
              && do { $state = $quo = QUO7; $heredoc = ''; redo };
          $state == QUO7 && m/^([^"\\\n]+)/gc && do { $heredoc .= $1; redo };
          $state == QUO7 && m/^((?:\\.)+)/gc  && do { $heredoc .= $1; redo };
          $state == QUO7
              && m/^\"/gc
              && do { $state = HERE; $heredoc =~ s/\\\"/\"/g; redo };
  
          $state == PAR
              && m/^<<(\w*)/gc
              && do { $state = HERE; $quo = QUO7; $heredoc = $1; redo };
  
          # jump ahaid and get the heredoc, then s/// also
          # resets the pos and we are back at the current pos
          $state == HERE
              && m/^.*\r?\n/gc
              && s/\G(.*?\r?\n)$heredoc(\r?\n)//s
              && do { $state = PAR; $str_part .= $1; $line_offset++; redo };
  
          # end ()
          #
  
          $state == PAR && m/^\s*[\)]/gc && do {
              $state = NUL;
              $vars =~ s/[\n\r]//g if ($vars);
              $self->add_entry( $str,
                  $line - ( () = $str =~ /\n/g ) - $line_offset, $vars )
                  if $str;
              undef $str;
              undef $vars;
              undef $heredoc;
              $line_offset = 0;
              redo;
          };
  
          # a line of vars
          $state == PAR && m/^([^\)]*)/gc && do { $vars .= "$1\n"; redo };
      }
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Perl - Perl format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::Perl->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise (including HEREDOCS and
  concatenated strings) from Perl code.
  
  This Perl parser is very fast and very good, but not perfect - it does make
  mistakes. The PPI parser (L<Locale::Maketext::Extract::Plugin::PPI>) is more
  accurate, but a lot slower, and so is not enabled by default.
  
  =head1 SHORT PLUGIN NAME
  
      perl
  
  =head1 VALID FORMATS
  
  Valid localization function names are:
  
  =over 4
  
  =item translate
  
  =item maketext
  
  =item gettext
  
  =item l
  
  =item loc
  
  =item x
  
  =item _
  
  =item __
  
  =back
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .pm
  
  =item .pl
  
  =item .cgi
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::PPI>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_PERL

$fatpacked{"Locale/Maketext/Extract/Plugin/TT2.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_TT2';
  package Locale::Maketext::Extract::Plugin::TT2;
  {
    $Locale::Maketext::Extract::Plugin::TT2::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  use Template::Constants qw( :debug );
  use Template::Parser;
  
  # ABSTRACT: Template Toolkit format parser
  
  
  # import strip_quotes
  *strip_quotes
      = \&Locale::Maketext::Extract::Plugin::TT2::Directive::strip_quotes;
  
  our %PARSER_OPTIONS;
  
  #===================================
  sub file_types {
  #===================================
      return ( qw( tt tt2 html ), qr/\.tt2?\./ );
  }
  
  my %Escapes = map { ( "\\$_" => eval("qq(\\$_)") ) } qw(t n r f b a e);
  
  #===================================
  sub extract {
  #===================================
      my $self = shift;
      my $data = shift;
  
      $Template::Directive::PRETTY = 1;
      my $parser = Locale::Maketext::Extract::Plugin::TT2::Parser->new(
          %PARSER_OPTIONS,
          FACTORY   => 'Locale::Maketext::Extract::Plugin::TT2::Directive',
          FILE_INFO => 0,
      );
      _init_overrides($parser);
  
      $parser->{extracted} = [];
  
      $Locale::Maketext::Extract::Plugin::TT2::Directive::PARSER
          = $parser;    # hack
      $parser->parse($data)
          || die $parser->error;
  
      foreach my $entry ( @{ $parser->{extracted} } ) {
          $entry->[2] =~ s/^\((.*)\)$/$1/s;    # Remove () from vars
          $_ =~ s/\\'/'/gs                     # Unescape \'
              for @{$entry}[ 0, 2 ];
          $entry->[2] =~ s/\\(?!")/\\\\/gs;    # Escape all \ not followed by "
                                               # Escape argument lists correctly
          while ( my ( $char, $esc ) = each %Escapes ) {
              $entry->[2] =~ s/$esc/$char/g;
          }
          $entry->[1] =~ s/\D+.*$//;
          $self->add_entry(@$entry);
      }
  }
  
  #===================================
  sub _init_overrides {
  #===================================
      my $parser = shift;
  
      # Override the concatenation sub to return _ instead of .
      my $states = $parser->{STATES};
      foreach my $state ( @{$states} ) {
          if ( my $CAT_no = $state->{ACTIONS}{CAT} ) {
              my $CAT_rule_no
                  = $states->[ $states->[$CAT_no]{GOTOS}{expr} ]->{DEFAULT};
  
              # override the TT::Grammar sub which cats two args
              $parser->{RULES}[ -$CAT_rule_no ][2] = sub {
                  my $first  = ( $_[1] );
                  my $second = ( $_[3] );
                  if ( strip_quotes($first) && strip_quotes($second) ) {
  
                      # both are literal
                      return "'${first}${second}'";
                  }
                  else {
  
                      # at least one is an ident
                      return "$_[1] _ $_[3]";
                  }
              };
              last;
          }
      }
  }
  
  #===================================
  #===================================
  package Locale::Maketext::Extract::Plugin::TT2::Parser;
  {
    $Locale::Maketext::Extract::Plugin::TT2::Parser::VERSION = '0.96';
  }
  #===================================
  #===================================
  
  use base 'Template::Parser';
  
  # disabled location() because it was adding unneccessary text
  # to filter blocks
  #===================================
  sub location {''}
  #===================================
  
  # Custom TT parser for Locale::Maketext::Lexicon
  #
  # Written by Andy Wardley http://wardley.org/
  #
  # 18 September 2008
  #
  
  #-----------------------------------------------------------------------
  # custom directive generator to capture filters, variables and
  # massage a few other elements to make life easy.
  #-----------------------------------------------------------------------
  
  #===================================
  #===================================
  package Locale::Maketext::Extract::Plugin::TT2::Directive;
  {
    $Locale::Maketext::Extract::Plugin::TT2::Directive::VERSION = '0.96';
  }
  #===================================
  #===================================
  
  use base 'Template::Directive';
  
  our $PARSER;
  
  #===================================
  sub textblock {
  #===================================
      my ( $class, $text ) = @_;
      $text =~ s/([\\'])/\\$1/g;
      return "'$text'";
  }
  
  #===================================
  sub ident {
  #===================================
      my ( $class, $ident ) = @_;
      return "NULL" unless @$ident;
      if ( scalar @$ident <= 2 && !$ident->[1] ) {
          my $var = $ident->[0];
          $var =~ s/^'(.+)'$/$1/;
          return $var;
      }
      else {
          my @source = @$ident;
          my @dotted;
          my $first = 1;
          my $first_literal;
          while (@source) {
              my ( $name, $args ) = splice( @source, 0, 2 );
              if ($first) {
                  strip_quotes($name);
                  my $first_arg = $args && @$args ? $args->[0] : '';
                  $first_literal = strip_quotes($first_arg);
                  $first--;
              }
              elsif ( !strip_quotes($name) && $name =~ /\D/ ) {
                  $name = '$' . $name;
              }
              $name .= join_args($args);
              push( @dotted, $name );
          }
  
          my $got_i18n = 0;
  
          # Classic TT syntax [% l('...') %] or [% loc('....') %]
          if ( $first_literal
              && ( $ident->[0] eq "'l'" or $ident->[0] eq "'loc'" ) )
          {
              $got_i18n = 1;
          }
  
          # Mojolicious TT syntax [% c.l('...') %]
          elsif ( $ident->[0] eq "'c'" && $ident->[2] eq "'l'" ) {
              $got_i18n = 1;
              splice( @$ident, 0, 2 );
          }
  
          if ($got_i18n) {
              my $string = shift @{ $ident->[1] };
              strip_quotes($string);
              $string =~ s/\\\\/\\/g;
              my $args = join_args( $ident->[1] );
              push @{ $PARSER->{extracted} },
                  [ $string, ${ $PARSER->{LINE} }, $args ];
          }
          return join( '.', @dotted );
      }
  }
  
  #===================================
  sub text {
  #===================================
      my ( $class, $text ) = @_;
      $text =~ s/\\/\\\\/g;
      return "'$text'";
  }
  
  #===================================
  sub quoted {
  #===================================
      my ( $class, $items ) = @_;
      return '' unless @$items;
      return ( $items->[0] ) if scalar @$items == 1;
      return '(' . join( ' _ ', @$items ) . ')';
  }
  
  #===================================
  sub args {
  #===================================
      my ( $class, $args ) = @_;
      my $hash = shift @$args;
      push( @$args, '{ ' . join( ', ', @$hash ) . ' }' )    # named params
          if @$hash;
      return $args;
  }
  
  #===================================
  sub get {
  #===================================
      my ( $class, $expr ) = @_;
      return $expr;
  }
  
  #===================================
  sub filter {
  #===================================
      my ( $class, $lnameargs, $block ) = @_;
      my ( $name,  $args,      $alias ) = @$lnameargs;
      $name = $name->[0];
      return ''
          unless $name eq "'l'"
          or $name eq "'loc'"
          or $name eq "'c.l'";
      if ( strip_quotes($block) ) {
          $block =~ s/\\\\/\\/g;
          $args = join_args( $class->args($args) );
  
          # NOTE: line number is at end of block, and can be a range
          my ($end) = ( ${ $PARSER->{LINE} } =~ /^(\d+)/ );
          my $start = $end;
  
          # rewind line count for newlines
          $start -= $block =~ tr/\n//;
          my $line = $start == $end ? $start : "$start-$end";
          push @{ $PARSER->{extracted} }, [ $block, $line, $args ];
  
      }
      return '';
  }
  
  # strips outer single quotes from a string (modifies original string)
  # returns true if stripped, or false
  #===================================
  sub strip_quotes {
  #===================================
      return scalar $_[0] =~ s/^'(.*)'$/$1/s;
  }
  
  #===================================
  sub join_args {
  #===================================
      my $args = shift;
      return '' unless $args && @$args;
      my @new_args = (@$args);
      for (@new_args) {
          s/\\\\/\\/g;
          if ( strip_quotes($_) ) {
              s/"/\\"/g;
              $_ = qq{"$_"};
          }
      }
      return '(' . join( ', ', @new_args ) . ')';
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::TT2 - Template Toolkit format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::TT2->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise from Template Toolkit templates.
  
  =head1 SHORT PLUGIN NAME
  
      tt2
  
  =head1 VALID FORMATS
  
  Valid formats are:
  
  =over 4
  
  =item [% |l(args) %]string[% END %]
  
  =item [% 'string' | l(args) %]
  
  =item [% l('string',args) %]
  
  =item [% c.l('string') %]
  
  Also all the above combinations with C<c.> prepended should work
  correctly. This is the default syntax when using TT templates
  with L<Mojolicious>.
  
  =back
  
  l and loc are interchangeable.
  
  | and FILTER are interchangeable.
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .tt
  
  =item .tt2
  
  =item .html
  
  =item .tt.*
  
  =item .tt2.*
  
  =back
  
  =head1 REQUIRES
  
  L<Template>
  
  =head1 NOTES
  
  =over 4
  
  =item *
  
  B<BEWARE> Using the C<loc> form can give false positives if you use the Perl parser
  plugin on TT files.  If you want to use the C<loc> form, then you should
  specify the file types that you want to the Perl plugin to parse, or enable
  the default file types, eg:
  
     xgetext.pl -P perl ....        # default file types
     xgettext.pl -P perl=pl,pm  ... # specified file types
  
  =item *
  
  The string-to-be-localised must be a string, not a variable. We try not
  to extract calls to your localise function which contain variables eg:
  
      l('string',arg)  # extracted
      l(var,arg)       # not extracted
  
  This doesn't work for block filters, so don't do that. Eg:
  
      [%  FILTER l %]
         string [% var %]      # BAD!
      [% END %]
  
  =item *
  
  Getting the right line number is difficult in TT. Often it'll be a range
  of lines, or it may be thrown out by the use of PRE_CHOMP or POST_CHOMP.  It will
  always be within a few lines of the correct location.
  
  =item *
  
  If you have PRE/POST_CHOMP enabled by default in your templates, then you should
  extract the strings using the same values.  In order to set them, you can
  use the following wrapper script:
  
     #!/usr/bin/perl
  
     use Locale::Maketext::Extract::Run qw(xgettext);
     use Locale::Maketext::Extract::Plugin::TT2();
  
     %Locale::Maketext::Extract::Plugin::TT2::PARSER_OPTIONS = (
          PRE_CHOMP  => 1, # or 2
          POST_CHOMP => 1, # or 2
  
          # Also START/END_TAG, ANYCASE, INTERPOLATE, V1DOLLAR, EVAL_PERL
     );
  
     xgettext(@ARGV);
  
  =back
  
  =head1 ACKNOWLEDGEMENTS
  
  Thanks to Andy Wardley for writing the Template::Directive subclass which
  made this possible.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =item L<Template::Toolkit>
  
  =back
  
  =head1 AUTHORS
  
  Clinton Gormley E<lt>clint@traveljury.comE<gt>
  
  Andy Wardley http://wardley.org
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_TT2

$fatpacked{"Locale/Maketext/Extract/Plugin/TextTemplate.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_TEXTTEMPLATE';
  package Locale::Maketext::Extract::Plugin::TextTemplate;
  {
    $Locale::Maketext::Extract::Plugin::TextTemplate::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  # ABSTRACT: Text::Template format parser
  
  
  sub file_types {
      return qw( * );
  }
  
  sub extract {
      my $self = shift;
      local $_ = shift;
  
      my $line = 1;
      pos($_) = 0;
  
      # Text::Template
      if ( $_ =~ /^STARTTEXT$/m and $_ =~ /^ENDTEXT$/m ) {
          require HTML::Parser;
          require Lingua::EN::Sentence;
  
          {
  
              package Locale::Maketext::Extract::Plugin::TextTemplate::Parser;
  {
    $Locale::Maketext::Extract::Plugin::TextTemplate::Parser::VERSION = '0.96';
  }
              our @ISA = 'HTML::Parser';
              *{'text'} = sub {
                  my ( $self, $str, $is_cdata ) = @_;
                  my $sentences = Lingua::EN::Sentence::get_sentences($str)
                      or return;
                  $str =~ s/\n/ /g;
                  $str =~ s/^\s+//;
                  $str =~ s/\s+$//;
                  $self->add_entry( $str, $line );
              };
          }
  
          my $p = Locale::Maketext::Extract::Plugin::TextTemplate::Parser->new;
          while (m/\G((.*?)^(?:START|END)[A-Z]+$)/smg) {
              my ($str) = ($2);
              $line += ( () = ( $1 =~ /\n/g ) );    # cryptocontext!
              $p->parse($str);
              $p->eof;
          }
          $_ = '';
      }
  
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::TextTemplate - Text::Template format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::TextTemplate->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise from Text::Template files
  
  =head1 SHORT PLUGIN NAME
  
      text
  
  =head1 VALID FORMATS
  
  Sentences between STARTxxx and ENDxxx are extracted individually.
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item All file types
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::YAML>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_TEXTTEMPLATE

$fatpacked{"Locale/Maketext/Extract/Plugin/YAML.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_YAML';
  package Locale::Maketext::Extract::Plugin::YAML;
  {
    $Locale::Maketext::Extract::Plugin::YAML::VERSION = '0.96';
  }
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  # ABSTRACT: YAML format parser
  
  
  sub file_types {
      return qw( yaml yml conf );
  }
  
  sub extract {
      my $self = shift;
      my $data = shift;
  
      my $y = Locale::Maketext::Extract::Plugin::YAML::Extractor->new();
      $y->load($data);
  
      foreach my $entry ( @{ $y->found } ) {
          $self->add_entry(@$entry);
      }
  
  }
  
  package Locale::Maketext::Extract::Plugin::YAML::Extractor;
  {
    $Locale::Maketext::Extract::Plugin::YAML::Extractor::VERSION = '0.96';
  }
  
  use base qw(YAML::Loader);
  
  #===================================
  sub new {
  #===================================
      my $class = shift;
      my $self  = $class->SUPER::new(@_);
      $self->{found} = [];
      return $self;
  }
  
  #===================================
  sub check_scalar {
  #===================================
      my $self = shift;
      my $node = $_[0];
      if ( defined $node && !ref $node && $node =~ /^__?(["'])(.+)\1$/s ) {
          my $string = $2;
          my $line   = $_[1];
          push @{ $self->{found} }, [ $string, $line ];
      }
      return $node;
  }
  
  sub _parse_node {
      my $self = shift;
      my $line = $self->{_start_line}
          ||= length( $self->preface ) ? $self->line - 1 : $self->line;
      my $node = $self->SUPER::_parse_node(@_);
      $self->{start_line} = 0;
      return $self->check_scalar( $node, $line );
  }
  
  sub _parse_inline_seq {
      my $self = shift;
      my $line = $self->{_start_line} ||= $self->line;
      my $node = $self->SUPER::_parse_inline_seq(@_);
      foreach (@$node) {
          $self->check_scalar( $_, $line );
      }
      $self->{start_line} = 0;
      return $node;
  }
  
  sub _parse_inline_mapping {
      my $self = shift;
      my $line = $self->{_start_line} ||= $self->line;
      my $node = $self->SUPER::_parse_inline_mapping(@_);
      foreach ( values %$node ) {
          $self->check_scalar( $_, $line );
      }
      $self->{start_line} = 0;
      return $node;
  }
  
  #===================================
  sub _parse_next_line {
  #===================================
      my $self = shift;
      $self->{_start_line} = $self->line
          if $_[0] == YAML::Loader::COLLECTION;
      $self->SUPER::_parse_next_line(@_);
  }
  
  sub found {
      my $self = shift;
      return $self->{found};
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::YAML - YAML format parser
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      $plugin = Locale::Maketext::Extract::Plugin::YAML->new(
          $lexicon            # A Locale::Maketext::Extract object
          @file_types         # Optionally specify a list of recognised file types
      )
  
      $plugin->extract($filename,$filecontents);
  
  =head1 DESCRIPTION
  
  Extracts strings to localise from YAML files.
  
  =head1 SHORT PLUGIN NAME
  
      yaml
  
  =head1 VALID FORMATS
  
  Valid formats are:
  
  =over 4
  
  =item *
  
      key: _"string"
  
  =item *
  
      key: _'string'
  
  =item *
  
      key: _'string with embedded 'quotes''
  
  =item *
  
      key: |-
           _'my folded
           string
           to translate'
  
  Note, the left hand side of the folded string must line up with the C<_>,
  otherwise YAML adds spaces at the beginning of each line.
  
  =item *
  
      key: |-
           _'my block
           string
           to translate
           '
  Note, you must use the trailing C<-> so that YAMl doesn't add a carriage
  return after your final quote.
  
  =back
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .yaml
  
  =item .yml
  
  =item .conf
  
  =back
  
  =head1 REQUIRES
  
  L<YAML>
  
  =head1 NOTES
  
  The docs for the YAML module describes it as alpha code. It is not as tolerant
  of errors as L<YAML::Syck>. However, because it is pure Perl, it is easy
  to hook into.
  
  I have seen it enter endless loops, so if xgettext.pl hangs, try running it
  again with C<--verbose --verbose> (twice) enabled, so that you can see if
  the fault lies with YAML.  If it does, either correct the YAML source file,
  or use the file_types to exclude that file.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<xgettext.pl>
  
  for extracting translatable strings from common template
  systems and perl source files.
  
  =item L<YAML>
  
  =item L<Locale::Maketext::Lexicon>
  
  =item L<Locale::Maketext::Extract::Plugin::Base>
  
  =item L<Locale::Maketext::Extract::Plugin::FormFu>
  
  =item L<Locale::Maketext::Extract::Plugin::Perl>
  
  =item L<Locale::Maketext::Extract::Plugin::TT2>
  
  =item L<Locale::Maketext::Extract::Plugin::Mason>
  
  =item L<Locale::Maketext::Extract::Plugin::TextTemplate>
  
  =item L<Locale::Maketext::Extract::Plugin::Generic>
  
  =back
  
  =head1 AUTHORS
  
  Clinton Gormley E<lt>clint@traveljury.comE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_PLUGIN_YAML

$fatpacked{"Locale/Maketext/Extract/Run.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_RUN';
  package Locale::Maketext::Extract::Run;
  {
    $Locale::Maketext::Extract::Run::VERSION = '0.96';
  }
  
  use strict;
  use vars qw( @ISA @EXPORT_OK );
  use File::Spec::Functions qw(catfile);
  
  # ABSTRACT: Module interface to xgettext.pl
  
  
  use Cwd;
  use Config ();
  use File::Find;
  use Getopt::Long;
  use Locale::Maketext::Extract;
  use Exporter;
  
  use constant HAS_SYMLINK => ( $Config::Config{d_symlink} ? 1 : 0 );
  
  @ISA       = 'Exporter';
  @EXPORT_OK = 'xgettext';
  
  sub xgettext { __PACKAGE__->run(@_) }
  
  sub run {
      my $self = shift;
      local @ARGV = @_;
  
      my %opts;
      Getopt::Long::Configure("no_ignore_case");
      Getopt::Long::GetOptions(
          \%opts,               'f|files-from:s@',
          'D|directory:s@',     'u|use-gettext-style|unescaped',
          'g|gnu-gettext',      'o|output:s@',
          'd|default-domain:s', 'p|output-dir:s@',
          'P|plugin:s@',        'W|wrap!',
          'w|warnings!',        'v|verbose+',
          'h|help',
      ) or help();
  
      help() if $opts{h};
  
      my %extract_options = %{ $self->_parse_extract_options( \%opts ) };
  
      my @po = @{ $opts{o} || [ ( $opts{d} || 'messages' ) . '.po' ] };
  
      foreach my $file ( @{ $opts{f} || [] } ) {
          open FILE, $file or die "Cannot open $file: $!";
          while (<FILE>) {
              chomp;
              push @ARGV, $_ if -r and !-d;
          }
      }
  
      foreach my $dir ( @{ $opts{D} || [] } ) {
          File::Find::find(
              {   wanted => sub {
                      if (-d) {
                          $File::Find::prune
                              = /^(\.svn|blib|autogen|var|m4|local|CVS|\.git)$/;
                          return;
                      }
  
                      # Only extract from non-binary, normal files
                      return unless ( -f or -s ) and -T;
                      return
                          if (/\.po$|\.bak$|~|,D|,B$/i)
                          || (/^[\.#]/);
                      push @ARGV, $File::Find::name;
                  },
                  follow => HAS_SYMLINK,
              },
              $dir
          );
      }
  
      @ARGV = ('-') unless @ARGV;
      s!^\.[/\\]!! for @ARGV;
  
      my $cwd = getcwd();
  
      my $Ext = Locale::Maketext::Extract->new(%extract_options);
      foreach my $dir ( @{ $opts{p} || ['.'] } ) {
          $Ext->extract_file($_) for grep !/\.po$/i, @ARGV;
          foreach my $po (@po) {
              $Ext->read_po($po) if -r $po and -s _;
              $Ext->compile( $opts{u} ) or next;
              $Ext->write_po( catfile( $dir, $po ), $opts{g} );
          }
      }
  }
  
  sub _parse_extract_options {
      my $self = shift;
      my $opts = shift;
  
      # If a list of plugins is specified, then we use those modules
      # plus their default list of file extensionse
      # and warnings enabled by default
  
      my %extract_options
          = ( verbose => $opts->{v}, wrap => $opts->{W} || 0 );
  
      if ( my $plugin_args = $opts->{P} ) {
  
          # file extension with potentially multiple dots eg .tt.html
          my %plugins;
  
          foreach my $param (@$plugin_args) {
              my ( $plugin, $args )
                  = ( $param =~ /^([a-z_]\w+(?:::\w+)*)(?:=(.+))?$/i );
              die "Couldn't understand plugin option '$param'"
                  unless $plugin;
              my @extensions;
              if ($args) {
                  foreach my $arg ( split /,/, $args ) {
                      if ( $arg eq '*' ) {
                          @extensions = ('*');
                          last;
                      }
                      my ($extension) = ( $arg =~ /^\.?(\w+(?:\.\w+)*)$/ );
                      die "Couldn't understand '$arg' in plugin '$param'"
                          unless defined $extension;
                      push @extensions, $extension;
                  }
              }
  
              $plugins{$plugin} = \@extensions;
          }
          $extract_options{plugins} = \%plugins;
          $extract_options{warnings} = exists $opts->{w} ? $opts->{w} : 1;
      }
  
      # otherwise we default to the original xgettext.pl modules
      # with warnings disabled by default
      else {
          $extract_options{warnings} = $opts->{w};
      }
      return \%extract_options;
  
  }
  
  sub help {
      local $SIG{__WARN__} = sub { };
      { exec "perldoc $0"; }
      { exec "pod2text $0"; }
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Extract::Run - Module interface to xgettext.pl
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      use Locale::Maketext::Extract::Run 'xgettext';
      xgettext(@ARGV);
  
  =head1 COPYRIGHT
  
  Copyright 2003-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_EXTRACT_RUN

$fatpacked{"Locale/Maketext/Lexicon.pm"} = <<'LOCALE_MAKETEXT_LEXICON';
  package Locale::Maketext::Lexicon;
  {
    $Locale::Maketext::Lexicon::VERSION = '0.96';
  }
  
  use 5.004;
  use strict;
  
  # ABSTRACT: Use other catalog formats in Maketext
  
  
  our %Opts;
  sub option { shift if ref( $_[0] ); $Opts{ lc $_[0] } }
  sub set_option { shift if ref( $_[0] ); $Opts{ lc $_[0] } = $_[1] }
  
  sub encoding {
      my $encoding = option( @_, 'encoding' ) or return;
      return $encoding unless lc($encoding) eq 'locale';
  
      local $^W;    # no warnings 'uninitialized', really.
      my ( $country_language, $locale_encoding );
  
      local $@;
      eval {
          require I18N::Langinfo;
          $locale_encoding
              = I18N::Langinfo::langinfo( I18N::Langinfo::CODESET() );
      } or eval {
          require Win32::Console;
          $locale_encoding = 'cp' . Win32::Console::OutputCP();
      };
      if ( !$locale_encoding ) {
          foreach my $key (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
              $ENV{$key} =~ /^([^.]+)\.([^.:]+)/ or next;
              ( $country_language, $locale_encoding ) = ( $1, $2 );
              last;
          }
      }
      if (   defined $locale_encoding
          && lc($locale_encoding) eq 'euc'
          && defined $country_language )
      {
          if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
              $locale_encoding = 'euc-jp';
          }
          elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
              $locale_encoding = 'euc-kr';
          }
          elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)?$/i ) {
              $locale_encoding = 'euc-cn';
          }
          elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
              $locale_encoding = 'euc-tw';
          }
      }
  
      return $locale_encoding;
  }
  
  sub import {
      my $class = shift;
      return unless @_;
  
      my %entries;
      if ( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
  
          # a hashref with $lang as keys, [$format, $src ...] as values
          %entries = %{ $_[0] };
      }
      elsif ( @_ % 2 == 0 ) {
          %entries = ( '' => [ splice @_, 0, 2 ], @_ );
      }
  
      # expand the wildcard entry
      if ( my $wild_entry = delete $entries{'*'} ) {
          while ( my ( $format, $src ) = splice( @$wild_entry, 0, 2 ) ) {
              next if ref($src); # XXX: implement globbing for the 'Tie' backend
  
              my $pattern = quotemeta($src);
              $pattern =~ s/\\\*(?=[^*]+$)/\([-\\w]+\)/g or next;
              $pattern =~ s/\\\*/.*?/g;
              $pattern =~ s/\\\?/./g;
              $pattern =~ s/\\\[/[/g;
              $pattern =~ s/\\\]/]/g;
              $pattern =~ s[\\\{(.*?)\\\\}][
                  '(?:'.join('|', split(/,/, $1)).')'
              ]eg;
  
              require File::Glob;
              foreach my $file ( File::Glob::bsd_glob($src) ) {
                  $file =~ /$pattern/ or next;
                  push @{ $entries{$1} }, ( $format => $file ) if $1;
              }
              delete $entries{$1}
                  unless !defined($1)
                  or exists $entries{$1} and @{ $entries{$1} };
          }
      }
  
      %Opts = ();
      foreach my $key ( grep /^_/, keys %entries ) {
          set_option( lc( substr( $key, 1 ) ) => delete( $entries{$key} ) );
      }
      my $OptsRef = {%Opts};
  
      while ( my ( $lang, $entry ) = each %entries ) {
          my $export = caller;
  
          if ( length $lang ) {
  
              # normalize language tag to Maketext's subclass convention
              $lang = lc($lang);
              $lang =~ s/-/_/g;
              $export .= "::$lang";
          }
  
          my @pairs = @{ $entry || [] } or die "no format specified";
  
          while ( my ( $format, $src ) = splice( @pairs, 0, 2 ) ) {
              if ( defined($src) and !ref($src) and $src =~ /\*/ ) {
                  unshift( @pairs, $format => $_ )
                      for File::Glob::bsd_glob($src);
                  next;
              }
  
              my @content
                  = eval { $class->lexicon_get( $src, scalar caller(1), $lang ); };
              next if $@ and $@ =~ /^next\b/;
              die $@ if $@;
  
              no strict 'refs';
              eval "use $class\::$format; 1" or die $@;
  
              if ( %{"$export\::Lexicon"} ) {
                  my $lexicon = \%{"$export\::Lexicon"};
                  if ( my $obj = tied %$lexicon ) {
  
                      # if it's our tied hash then force loading
                      # otherwise late load will rewrite
                      $obj->_force if $obj->isa(__PACKAGE__);
                  }
  
                  # clear the memoized cache for old entries:
                  Locale::Maketext->clear_isa_scan;
  
                  my $new = "$class\::$format"->parse(@content);
  
                  # avoid hash rebuild, on big sets
                  @{$lexicon}{ keys %$new } = values %$new;
              }
              else {
                  local $^W if $] >= 5.009;    # no warnings 'once', really.
                  tie %{"$export\::Lexicon"}, __PACKAGE__,
                      {
                      Opts    => $OptsRef,
                      Export  => "$export\::Lexicon",
                      Class   => "$class\::$format",
                      Content => \@content,
                      };
                  tied( %{"$export\::Lexicon"} )->_force
                      if $OptsRef->{'preload'};
              }
  
              length $lang or next;
  
              # Avoid re-entry
              my $caller = caller();
              next if $export->isa($caller);
  
              push( @{"$export\::ISA"}, scalar caller );
  
              if ( my $style = option('style') ) {
                  my $cref
                      = $class->can( lc("_style_$style") )
                      ->( $class, $export->can('maketext') )
                      or die "Unknown style: $style";
  
                  # Avoid redefinition warnings
                  local $SIG{__WARN__} = sub {1};
                  *{"$export\::maketext"} = $cref;
              }
          }
      }
  }
  
  sub _style_gettext {
      my ( $self, $orig ) = @_;
  
      require Locale::Maketext::Lexicon::Gettext;
  
      sub {
          my $lh  = shift;
          my $str = shift;
          return $orig->(
              $lh,
              Locale::Maketext::Lexicon::Gettext::_gettext_to_maketext($str), @_
          );
          }
  }
  
  sub TIEHASH {
      my ( $class, $args ) = @_;
      return bless( $args, $class );
  
  }
  
  {
      no strict 'refs';
  
      sub _force {
          my $args = shift;
          unless ( $args->{'Done'} ) {
              $args->{'Done'} = 1;
              local *Opts = $args->{Opts};
              *{ $args->{Export} }
                  = $args->{Class}->parse( @{ $args->{Content} } );
              $args->{'Export'}{'_AUTO'} = 1
                  if option('auto');
          }
          return $args->{'Export'};
      }
      sub FETCH   { _force( $_[0] )->{ $_[1] } }
      sub EXISTS  { _force( $_[0] )->{ $_[1] } }
      sub DELETE  { delete _force( $_[0] )->{ $_[1] } }
      sub SCALAR  { scalar %{ _force( $_[0] ) } }
      sub STORE   { _force( $_[0] )->{ $_[1] } = $_[2] }
      sub CLEAR   { %{ _force( $_[0] )->{ $_[1] } } = () }
      sub NEXTKEY { each %{ _force( $_[0] ) } }
  
      sub FIRSTKEY {
          my $hash = _force( $_[0] );
          my $a    = scalar keys %$hash;
          each %$hash;
      }
  }
  
  sub lexicon_get {
      my ( $class, $src, $caller, $lang ) = @_;
      return unless defined $src;
  
      foreach my $type ( qw(ARRAY HASH SCALAR GLOB), ref($src) ) {
          next unless UNIVERSAL::isa( $src, $type );
  
          my $method = 'lexicon_get_' . lc($type);
          die "cannot handle source $type for $src: no $method defined"
              unless $class->can($method);
  
          return $class->$method( $src, $caller, $lang );
      }
  
      # default handler
      return $class->lexicon_get_( $src, $caller, $lang );
  }
  
  # for scalarrefs and arrayrefs we just dereference the $src
  sub lexicon_get_scalar { ${ $_[1] } }
  sub lexicon_get_array  { @{ $_[1] } }
  
  sub lexicon_get_hash {
      my ( $class, $src, $caller, $lang ) = @_;
      return map { $_ => $src->{$_} } sort keys %$src;
  }
  
  sub lexicon_get_glob {
      my ( $class, $src, $caller, $lang ) = @_;
  
      no strict 'refs';
      local $^W if $] >= 5.009;    # no warnings 'once', really.
  
      # be extra magical and check for DATA section
      if ( eof($src) and $src eq \*{"$caller\::DATA"}
          or $src eq \*{"main\::DATA"} )
      {
  
          # okay, the *DATA isn't initiated yet. let's read.
          #
          require FileHandle;
          my $fh = FileHandle->new;
          my $package = ( ( $src eq \*{"main\::DATA"} ) ? 'main' : $caller );
  
          if ( $package eq 'main' and -e $0 ) {
              $fh->open($0) or die "Can't open $0: $!";
          }
          else {
              my $level = 1;
              while ( my ( $pkg, $filename ) = caller( $level++ ) ) {
                  next unless $pkg eq $package;
                  next unless -e $filename;
                  next;
  
                  $fh->open($filename) or die "Can't open $filename: $!";
                  last;
              }
          }
  
          while (<$fh>) {
  
              # okay, this isn't foolproof, but good enough
              last if /^__DATA__$/;
          }
  
          return <$fh>;
      }
  
      # fh containing the lines
      my $pos   = tell($src);
      my @lines = <$src>;
      seek( $src, $pos, 0 );
      return @lines;
  }
  
  # assume filename - search path, open and return its contents
  sub lexicon_get_ {
      my ( $class, $src, $caller, $lang ) = @_;
      $src = $class->lexicon_find( $src, $caller, $lang );
      defined $src or die 'next';
  
      require FileHandle;
      my $fh = FileHandle->new;
      $fh->open($src) or die "Cannot read $src (called by $caller): $!";
      binmode($fh);
      return <$fh>;
  }
  
  sub lexicon_find {
      my ( $class, $src, $caller, $lang ) = @_;
      return $src if -e $src;
  
      require File::Spec;
  
      my @path = split '::', $caller;
      push @path, $lang if length $lang;
  
      while (@path) {
          foreach (@INC) {
              my $file = File::Spec->catfile( $_, @path, $src );
              return $file if -e $file;
          }
          pop @path;
      }
  
      return undef;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Lexicon - Use other catalog formats in Maketext
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
  As part of a localization class, automatically glob for available
  lexicons:
  
      package Hello::I18N;
      use base 'Locale::Maketext';
      use Locale::Maketext::Lexicon {
          '*' => [Gettext => '/usr/local/share/locale/*/LC_MESSAGES/hello.mo'],
          ### Uncomment to fallback when a key is missing from lexicons
          # _auto   => 1,
          ### Uncomment to decode lexicon entries into Unicode strings
          # _decode => 1,
          ### Uncomment to load and parse everything right away
          # _preload => 1,
          ### Uncomment to use %1 / %quant(%1) instead of [_1] / [quant, _1]
          # _style  => 'gettext',
      };
  
  Explicitly specify languages, during compile- or run-time:
  
      package Hello::I18N;
      use base 'Locale::Maketext';
      use Locale::Maketext::Lexicon {
          de => [Gettext => 'hello_de.po'],
          fr => [
              Gettext => 'hello_fr.po',
              Gettext => 'local/hello/fr.po',
          ],
      };
      # ... incrementally add new lexicons
      Locale::Maketext::Lexicon->import({
          de => [Gettext => 'local/hello/de.po'],
      })
  
  Alternatively, as part of a localization subclass:
  
      package Hello::I18N::de;
      use base 'Hello::I18N';
      use Locale::Maketext::Lexicon (Gettext => \*DATA);
      __DATA__
      # Some sample data
      msgid ""
      msgstr ""
      "Project-Id-Version: Hello 1.3.22.1\n"
      "MIME-Version: 1.0\n"
      "Content-Type: text/plain; charset=iso8859-1\n"
      "Content-Transfer-Encoding: 8bit\n"
  
      #: Hello.pm:10
      msgid "Hello, World!"
      msgstr "Hallo, Welt!"
  
      #: Hello.pm:11
      msgid "You have %quant(%1,piece) of mail."
      msgstr "Sie haben %quant(%1,Poststueck,Poststuecken)."
  
  =head1 DESCRIPTION
  
  This module provides lexicon-handling modules to read from other
  localization formats, such as I<Gettext>, I<Msgcat>, and so on.
  
  If you are unfamiliar with the concept of lexicon modules, please
  consult L<Locale::Maketext> and the C<webl10n> HTML files in the C<docs/>
  directory of this module.
  
  A command-line utility L<xgettext.pl> is also installed with this
  module, for extracting translatable strings from source files.
  
  =head2 The C<import> function
  
  The C<import()> function accepts two forms of arguments:
  
  =over 4
  
  =item (I<format> => I<source> ... )
  
  This form takes any number of argument pairs (usually one);
  I<source> may be a file name, a filehandle, or an array reference.
  
  For each such pair, it pass the contents specified by the second
  argument to B<Locale::Maketext::Lexicon::I<format>>->parse as a
  plain list, and export its return value as the C<%Lexicon> hash
  in the calling package.
  
  In the case that there are multiple such pairs, the lexicon
  defined by latter ones overrides earlier ones.
  
  =item { I<language> => [ I<format>, I<source> ... ] ... }
  
  This form accepts a hash reference.  It will export a C<%Lexicon>
  into the subclasses specified by each I<language>, using the process
  described above.  It is designed to alleviate the need to set up a
  separate subclass for each localized language, and just use the catalog
  files.
  
  This module will convert the I<language> arguments into lowercase,
  and replace all C<-> with C<_>, so C<zh_TW> and C<zh-tw> will both
  map to the C<zh_tw> subclass.
  
  If I<language> begins with C<_>, it is taken as an option that
  controls how lexicons are parsed.  See L</Options> for a list
  of available options.
  
  The C<*> is a special I<language>; it must be used in conjunction
  with a filename that also contains C<*>; all matched files with
  a valid language code in the place of C<*> will be automatically
  prepared as a lexicon subclass.  If there is multiple C<*> in
  the filename, the last one is used as the language name.
  
  =back
  
  =head2 Options
  
  =over 4
  
  =item C<_auto>
  
  If set to a true value, missing lookups on lexicons are handled
  silently, as if an C<Auto> lexicon has been appended on all
  language lexicons.
  
  =item C<_decode>
  
  If set to a true value, source entries will be converted into
  utf8-strings (available in Perl 5.6.1 or later).  This feature
  needs the B<Encode> or B<Encode::compat> module.
  
  Currently, only the C<Gettext> backend supports this option.
  
  =item C<_encoding>
  
  This option only has effect when C<_decode> is set to true.
  It specifies an encoding to store lexicon entries, instead of
  utf8-strings.
  
  If C<_encoding> is set to C<locale>, the encoding from the
  current locale setting is used.
  
  =item C<_preload>
  
  By default parsing is delayed until first use of the lexicon,
  set this option to true value to parse it asap. Increment
  adding lexicons forces parsing.
  
  =back
  
  =head2 Subclassing format handlers
  
  If you wish to override how sources specified in different data types
  are handled, please use a subclass that overrides C<lexicon_get_I<TYPE>>.
  
  XXX: not documented well enough yet.  Patches welcome.
  
  =head1 VERSION
  
  This document describes version 0.91 of Locale::Maketext::Lexicon.
  
  =head1 NOTES
  
  When you attempt to localize an entry missing in the lexicon, Maketext
  will throw an exception by default.  To inhibit this behaviour, override
  the C<_AUTO> key in your language subclasses, for example:
  
      $Hello::I18N::en::Lexicon{_AUTO} = 1; # autocreate missing keys
  
  If you want to implement a new C<Lexicon::*> backend module, please note
  that C<parse()> takes an array containing the B<source strings> from the
  specified filehandle or filename, which are I<not> C<chomp>ed.  Although
  if the source is an array reference, its elements will probably not contain
  any newline characters anyway.
  
  The C<parse()> function should return a hash reference, which will be
  assigned to the I<typeglob> (C<*Lexicon>) of the language module.  All
  it amounts to is that if the returned reference points to a tied hash,
  the C<%Lexicon> will be aliased to the same tied hash if it was not
  initialized previously.
  
  =head1 ACKNOWLEDGMENTS
  
  Thanks to Jesse Vincent for suggesting this module to be written.
  
  Thanks also to Sean M. Burke for coming up with B<Locale::Maketext>
  in the first place, and encouraging me to experiment with alternative
  Lexicon syntaxes.
  
  Thanks also to Yi Ma Mao for providing the MO file parsing subroutine,
  as well as inspiring me to implement file globbing and transcoding
  support.
  
  See the F<AUTHORS> file in the distribution for a list of people who
  have sent helpful patches, ideas or comments.
  
  =head1 SEE ALSO
  
  L<xgettext.pl> for extracting translatable strings from common template
  systems and perl source files.
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon::Auto>,
  L<Locale::Maketext::Lexicon::Gettext>, L<Locale::Maketext::Lexicon::Msgcat>,
  L<Locale::Maketext::Lexicon::Tie>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_LEXICON

$fatpacked{"Locale/Maketext/Lexicon/Auto.pm"} = <<'LOCALE_MAKETEXT_LEXICON_AUTO';
  package Locale::Maketext::Lexicon::Auto;
  {
    $Locale::Maketext::Lexicon::Auto::VERSION = '0.96';
  }
  
  use strict;
  
  # ABSTRACT: Auto fallback lexicon for Maketext
  
  
  sub parse {
      +{ _AUTO => 1 };
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Auto - Auto fallback lexicon for Maketext
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      package Hello::I18N;
      use base 'Locale::Maketext';
      use Locale::Maketext::Lexicon {
          en => ['Auto'],
          # ... other languages
      };
  
  =head1 DESCRIPTION
  
  This module builds a simple Lexicon hash that contains nothing but
  C<( '_AUTO' =E<gt> 1)>, which tells C<Locale::Maketext> that no
  localizing is needed -- just use the lookup key as the returned string.
  
  It is especially useful if you're starting to prototype a program, and
  do not want to deal with the localization files yet.
  
  =head1 CAVEATS
  
  If the key to C<-E<gt>maketext> begins with a C<_>, C<Locale::Maketext>
  will still throw an exception.  See L<Locale::Maketext/CONTROLLING LOOKUP
  FAILURE> for how to prevent it.
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002 - 2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_LEXICON_AUTO

$fatpacked{"Locale/Maketext/Lexicon/Gettext.pm"} = <<'LOCALE_MAKETEXT_LEXICON_GETTEXT';
  package Locale::Maketext::Lexicon::Gettext;
  {
    $Locale::Maketext::Lexicon::Gettext::VERSION = '0.96';
  }
  
  use strict;
  
  # ABSTRACT: PO and MO file parser for Maketext
  
  
  my ( $InputEncoding, $OutputEncoding, $DoEncoding );
  
  sub input_encoding  {$InputEncoding}
  sub output_encoding {$OutputEncoding}
  
  sub parse {
      my $self = shift;
      my ( %var, $key, @ret );
      my @metadata;
      my @comments;
      my @fuzzy;
  
      $InputEncoding = $OutputEncoding = $DoEncoding = undef;
  
      use Carp;
      Carp::cluck "Undefined source called\n" unless defined $_[0];
  
      # Check for magic string of MO files
      return parse_mo( join( '', @_ ) )
          if ( $_[0] =~ /^\x95\x04\x12\xde/ or $_[0] =~ /^\xde\x12\x04\x95/ );
  
      local $^W;    # no 'uninitialized' warnings, please.
  
      require Locale::Maketext::Lexicon;
      my $KeepFuzzy = Locale::Maketext::Lexicon::option('keep_fuzzy');
      my $UseFuzzy  = $KeepFuzzy
          || Locale::Maketext::Lexicon::option('use_fuzzy');
      my $AllowEmpty = Locale::Maketext::Lexicon::option('allow_empty');
      my $process    = sub {
          if ( length( $var{msgstr} ) and ( $UseFuzzy or !$var{fuzzy} ) ) {
              push @ret, ( map transform($_), @var{ 'msgid', 'msgstr' } );
          }
          elsif ($AllowEmpty) {
              push @ret, ( transform( $var{msgid} ), '' );
          }
          if ( $var{msgid} eq '' ) {
              push @metadata, parse_metadata( $var{msgstr} );
          }
          else {
              push @comments, $var{msgid}, $var{msgcomment};
          }
          if ( $KeepFuzzy && $var{fuzzy} ) {
              push @fuzzy, $var{msgid}, 1;
          }
          %var = ();
      };
  
      # Parse PO files
      foreach (@_) {
          s/[\015\012]*\z//;    # fix CRLF issues
  
          /^(msgid|msgstr) +"(.*)" *$/
              ? do {            # leading strings
              $var{$1} = $2;
              $key = $1;
              }
              :
  
              /^"(.*)" *$/
              ? do {            # continued strings
              $var{$key} .= $1;
              }
              :
  
              /^# (.*)$/
              ? do {            # user comments
              $var{msgcomment} .= $1 . "\n";
              }
              :
  
              /^#, +(.*) *$/
              ? do {            # control variables
              $var{$_} = 1 for split( /,\s+/, $1 );
              }
              :
  
              /^ *$/ && %var
              ? do {            # interpolate string escapes
              $process->($_);
              }
              : ();
  
      }
  
      # do not silently skip last entry
      $process->() if keys %var != 0;
  
      push @ret, map { transform($_) } @var{ 'msgid', 'msgstr' }
          if length $var{msgstr};
      push @metadata, parse_metadata( $var{msgstr} )
          if $var{msgid} eq '';
  
      return wantarray
          ? ( { @metadata, @ret }, {@comments}, {@fuzzy} )
          : ( { @metadata, @ret } );
  
  }
  
  sub parse_metadata {
      return map {
                (/^([^\x00-\x1f\x80-\xff :=]+):\s*(.*)$/)
              ? ( $1 eq 'Content-Type' )
                  ? do {
                      my $enc = $2;
                      if ( $enc =~ /\bcharset=\s*([-\w]+)/i ) {
                          $InputEncoding = $1 || '';
                          $OutputEncoding
                              = Locale::Maketext::Lexicon::encoding()
                              || '';
                          $InputEncoding = 'utf8'
                              if $InputEncoding =~ /^utf-?8$/i;
                          $OutputEncoding = 'utf8'
                              if $OutputEncoding =~ /^utf-?8$/i;
                          if (Locale::Maketext::Lexicon::option('decode')
                              and ( !$OutputEncoding
                                  or $InputEncoding ne $OutputEncoding )
                              )
                          {
                              require Encode::compat if $] < 5.007001;
                              require Encode;
                              $DoEncoding = 1;
                          }
                      }
                      ( "__Content-Type", $enc );
                  }
                  : ( "__$1", $2 )
              : ();
      } split( /\r*\n+\r*/, transform(pop) );
  }
  
  sub transform {
      my $str = shift;
  
      if ( $DoEncoding and $InputEncoding ) {
          $str
              = ( $InputEncoding eq 'utf8' )
              ? Encode::decode_utf8($str)
              : Encode::decode( $InputEncoding, $str );
      }
  
      $str =~ s/\\([0x]..|c?.)/qq{"\\$1"}/eeg;
  
      if ( $DoEncoding and $OutputEncoding ) {
          $str
              = ( $OutputEncoding eq 'utf8' )
              ? Encode::encode_utf8($str)
              : Encode::encode( $OutputEncoding, $str );
      }
  
      return _gettext_to_maketext($str);
  }
  
  sub _gettext_to_maketext {
      my $str = shift;
      $str =~ s{([\~\[\]])}{~$1}g;
      $str =~ s{
          ([%\\]%)                        # 1 - escaped sequence
      |
          %   (?:
                  ([A-Za-z#*]\w*)         # 2 - function call
                      \(([^\)]*)\)        # 3 - arguments
              |
                  ([1-9]\d*|\*)           # 4 - variable
              )
      }{
          $1 ? $1
             : $2 ? "\[$2,"._unescape($3)."]"
                  : "[_$4]"
      }egx;
      $str;
  }
  
  sub _unescape {
      join( ',',
          map { /\A(\s*)%([1-9]\d*|\*)(\s*)\z/ ? "$1_$2$3" : $_ }
              split( /,/, $_[0] ) );
  }
  
  # This subroutine was derived from Locale::Maketext::Gettext::readmo()
  # under the Perl License; the original author is Yi Ma Mao (IMACAT).
  sub parse_mo {
      my $content = shift;
      my $tmpl = ( substr( $content, 0, 4 ) eq "\xde\x12\x04\x95" ) ? 'V' : 'N';
  
      # Check the MO format revision number
      # There is only one revision now: revision 0.
      return if unpack( $tmpl, substr( $content, 4, 4 ) ) > 0;
  
      my ( $num, $offo, $offt );
  
      # Number of strings
      $num = unpack $tmpl, substr( $content, 8, 4 );
  
      # Offset to the beginning of the original strings
      $offo = unpack $tmpl, substr( $content, 12, 4 );
  
      # Offset to the beginning of the translated strings
      $offt = unpack $tmpl, substr( $content, 16, 4 );
  
      my ( @metadata, @ret );
      for ( 0 .. $num - 1 ) {
          my ( $len, $off, $stro, $strt );
  
          # The first word is the length of the string
          $len = unpack $tmpl, substr( $content, $offo + $_ * 8, 4 );
  
          # The second word is the offset of the string
          $off = unpack $tmpl, substr( $content, $offo + $_ * 8 + 4, 4 );
  
          # Original string
          $stro = substr( $content, $off, $len );
  
          # The first word is the length of the string
          $len = unpack $tmpl, substr( $content, $offt + $_ * 8, 4 );
  
          # The second word is the offset of the string
          $off = unpack $tmpl, substr( $content, $offt + $_ * 8 + 4, 4 );
  
          # Translated string
          $strt = substr( $content, $off, $len );
  
          # Hash it
          push @metadata, parse_metadata($strt) if $stro eq '';
          push @ret, ( map transform($_), $stro, $strt ) if length $strt;
      }
  
      return { @metadata, @ret };
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Gettext - PO and MO file parser for Maketext
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
  Called via B<Locale::Maketext::Lexicon>:
  
      package Hello::I18N;
      use base 'Locale::Maketext';
      use Locale::Maketext::Lexicon {
          de => [Gettext => 'hello/de.mo'],
      };
  
  Directly calling C<parse()>:
  
      use Locale::Maketext::Lexicon::Gettext;
      my %Lexicon = %{ Locale::Maketext::Lexicon::Gettext->parse(<DATA>) };
      __DATA__
      #: Hello.pm:10
      msgid "Hello, World!"
      msgstr "Hallo, Welt!"
  
      #: Hello.pm:11
      msgid "You have %quant(%1,piece) of mail."
      msgstr "Sie haben %quant(%1,Poststueck,Poststuecken)."
  
  =head1 DESCRIPTION
  
  This module implements a perl-based C<Gettext> parser for
  B<Locale::Maketext>. It transforms all C<%1>, C<%2>, <%*>... sequences
  to C<[_1]>, C<[_2]>, C<[_*]>, and so on.  It accepts either plain PO
  file, or a MO file which will be handled with a pure-perl parser
  adapted from Imacat's C<Locale::Maketext::Gettext>.
  
  Since version 0.03, this module also looks for C<%I<function>(I<args...>)>
  in the lexicon strings, and transform it to C<[I<function>,I<args...>]>.
  Any C<%1>, C<%2>... sequences inside the I<args> will have their percent
  signs (C<%>) replaced by underscores (C<_>).
  
  The name of I<function> above should begin with a letter or underscore,
  followed by any number of alphanumeric characters and/or underscores.
  As an exception, the function name may also consist of a single asterisk
  (C<*>) or pound sign (C<#>), which are C<Locale::Maketext>'s shorthands
  for C<quant> and C<numf>, respectively.
  
  As an additional feature, this module also parses MIME-header style
  metadata specified in the null msgstr (C<"">), and add them to the
  C<%Lexicon> with a C<__> prefix.  For example, the example above will
  set C<__Content-Type> to C<text/plain; charset=iso8859-1>, without
  the newline or the colon.
  
  Any normal entry that duplicates a metadata entry takes precedence.
  Hence, a C<msgid "__Content-Type"> line occurs anywhere should override
  the above value.
  
  =head1 OPTIONS
  
  =head2 use_fuzzy
  
  When parsing PO files, fuzzy entries (entries marked with C<#, fuzzy>)
  are silently ignored.  If you wish to use fuzzy entries, specify a true
  value to the C<_use_fuzzy> option:
  
      use Locale::Maketext::Lexicon {
          de => [Gettext => 'hello/de.mo'],
          _use_fuzzy => 1,
      };
  
  =head2 allow_empty
  
  When parsing PO files, empty entries (entries with C<msgstr "">) are
  silently ignored.  If you wish to allow empty entries, specify a true
  value to the C<_allow_empty> option:
  
      use Locale::Maketext::Lexicon {
          de => [Gettext => 'hello/de.mo'],
          _allow_empty => 1,
      };
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_LEXICON_GETTEXT

$fatpacked{"Locale/Maketext/Lexicon/Msgcat.pm"} = <<'LOCALE_MAKETEXT_LEXICON_MSGCAT';
  package Locale::Maketext::Lexicon::Msgcat;
  {
    $Locale::Maketext::Lexicon::Msgcat::VERSION = '0.96';
  }
  
  use strict;
  
  # ABSTRACT: Msgcat catalog parser Maketext
  
  
  sub parse {
      my $set = 0;
      my $msg = undef;
      my ( $qr, $qq, $qc ) = ( qr//, '', '' );
      my @out;
  
      # Set up the msgcat handler
      {
          no strict 'refs';
          no warnings 'once';
          *{Locale::Maketext::msgcat} = \&_msgcat;
      }
  
      # Parse *.m files; Locale::Msgcat objects and *.cat are not yet supported.
      foreach (@_) {
          s/[\015\012]*\z//;    # fix CRLF issues
  
          /^\$set (\d+)/
              ? do {            # set_id
              $set = int($1);
              push @out, $1, "[msgcat,$1,_1]";
              }
              :
  
              /^\$quote (.)/
              ? do {            # quote character
              $qc = $1;
              $qq = quotemeta($1);
              $qr = qr/$qq?/;
              }
              :
  
              /^(\d+) ($qr)(.*?)\2(\\?)$/
              ? do {            # msg_id and msg_str
              local $^W;
              push @out, "$set," . int($1);
              if ($4) {
                  $msg = $3;
              }
              else {
                  push @out, unescape( $qq, $qc, $3 );
                  undef $msg;
              }
              }
              :
  
              ( defined $msg and /^($qr)(.*?)\1(\\?)$/ )
              ? do {    # continued string
              local $^W;
              if ($3) {
                  $msg .= $2;
              }
              else {
                  push @out, unescape( $qq, $qc, $msg . $2 );
                  undef $msg;
              }
              }
              : ();
      }
  
      push @out, '' if defined $msg;
  
      return {@out};
  }
  
  sub _msgcat {
      my ( $self, $set_id, $msg_id, @args ) = @_;
      return $self->maketext( int($set_id) . ',' . int($msg_id), @args );
  }
  
  sub unescape {
      my ( $qq, $qc, $str ) = @_;
      $str =~ s/(\\([ntvbrf\\$qq]))/($2 eq $qc) ? $qc : eval qq("$1")/e;
      $str =~ s/([\~\[\]])/~$1/g;
      return $str;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Msgcat - Msgcat catalog parser Maketext
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      package Hello::I18N;
      use base 'Locale::Maketext';
      use Locale::Maketext::Lexicon {
          en => ['Msgcat', 'en_US/hello.pl.m'],
      };
  
      package main;
      my $lh = Hello::I18N->get_handle('en');
      print $lh->maketext(1,2);   # set 1, msg 2
      print $lh->maketext("1,2"); # same thing
  
  =head1 DESCRIPTION
  
  This module parses one or more Msgcat catalogs in plain text format,
  and returns a Lexicon hash, which may be looked up either with a
  two-argument form (C<$set_id, $msg_id>) or as a single string
  (C<"$set_id,$msg_id">).
  
  =head1 NOTES
  
  All special characters (C<[>, C<]> and C<~>) in catalogs will be
  escaped so they lose their magic meanings.  That means C<-E<gt>maketext>
  calls to this lexicon will I<not> take any additional arguments.
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_LEXICON_MSGCAT

$fatpacked{"Locale/Maketext/Lexicon/Tie.pm"} = <<'LOCALE_MAKETEXT_LEXICON_TIE';
  package Locale::Maketext::Lexicon::Tie;
  {
    $Locale::Maketext::Lexicon::Tie::VERSION = '0.96';
  }
  
  use strict;
  use Symbol ();
  
  # ABSTRACT: Use tied hashes as lexicons for Maketext
  
  
  sub parse {
      my $self = shift;
      my $mod  = shift;
      my $sym  = Symbol::gensym();
  
      # Load the target module into memory
      {
          no strict 'refs';
          eval "use $mod; 1" or die $@ unless %{"$mod\::"};
      }
  
      # Perform the actual tie
      tie %{*$sym}, $mod, @_;
  
      # Returns the GLOB reference, so %Lexicon will be tied too
      return $sym;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Tie - Use tied hashes as lexicons for Maketext
  
  =head1 VERSION
  
  version 0.96
  
  =head1 SYNOPSIS
  
      package Hello::I18N;
      use base 'Locale::Maketext';
      use Locale::Maketext::Lexicon {
          en => [ Tie => [ DB_File => 'en.db' ] ],
      };
  
  =head1 DESCRIPTION
  
  This module lets you easily C<tie> the C<%Lexicon> hash to a database
  or other data sources.  It takes an array reference of arguments, and
  passes them directly to C<tie()>.
  
  Entries will then be fetched whenever it is used; this module does not
  cache them.
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2013 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
  
  This software is released under the MIT license cited below.
  
  =head2 The "MIT" License
  
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to deal
  in the Software without restriction, including without limitation the rights
  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
  
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Clinton Gormley <drtech@cpan.org>
  
  =item *
  
  Audrey Tang <cpan@audreyt.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Audrey Tang.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
LOCALE_MAKETEXT_LEXICON_TIE

$fatpacked{"Method/Generate/Accessor.pm"} = <<'METHOD_GENERATE_ACCESSOR';
  package Method::Generate::Accessor;
  
  use strictures 1;
  use Moo::_Utils;
  use base qw(Moo::Object);
  use Sub::Quote;
  use B 'perlstring';
  use Scalar::Util 'blessed';
  use overload ();
  use Module::Runtime qw(use_module);
  BEGIN {
    our $CAN_HAZ_XS =
      !$ENV{MOO_XS_DISABLE}
        &&
      _maybe_load_module('Class::XSAccessor')
        &&
      (eval { Class::XSAccessor->VERSION('1.07') })
    ;
  }
  
  sub _SIGDIE
  {
    our ($CurrentAttribute, $OrigSigDie);
    $OrigSigDie ||= sub { die $_[0] };
    
    return $OrigSigDie->(@_) if ref($_[0]);
    
    my $attr_desc = _attr_desc(@$CurrentAttribute{qw(name init_arg)});
    $OrigSigDie->("$CurrentAttribute->{step} for $attr_desc failed: $_[0]");
  }
  
  sub _die_overwrite
  {
    my ($pkg, $method, $type) = @_;
    die "You cannot overwrite a locally defined method ($method) with @{[ $type || 'an accessor' ]}";
  }
  
  sub generate_method {
    my ($self, $into, $name, $spec, $quote_opts) = @_;
    $spec->{allow_overwrite}++ if $name =~ s/^\+//;
    die "Must have an is" unless my $is = $spec->{is};
    if ($is eq 'ro') {
      $spec->{reader} = $name unless exists $spec->{reader};
    } elsif ($is eq 'rw') {
      $spec->{accessor} = $name unless exists $spec->{accessor}
        or ( $spec->{reader} and $spec->{writer} );
    } elsif ($is eq 'lazy') {
      $spec->{reader} = $name unless exists $spec->{reader};
      $spec->{lazy} = 1;
      $spec->{builder} ||= '_build_'.$name unless $spec->{default};
    } elsif ($is eq 'rwp') {
      $spec->{reader} = $name unless exists $spec->{reader};
      $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
    } elsif ($is ne 'bare') {
      die "Unknown is ${is}";
    }
    if (exists $spec->{builder}) {
      if(ref $spec->{builder}) {
        $self->_validate_codulatable('builder', $spec->{builder},
          "$into->$name", 'or a method name');
        $spec->{builder_sub} = $spec->{builder};
        $spec->{builder} = 1;
      }
      $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
      die "Invalid builder for $into->$name - not a valid method name"
        if $spec->{builder} !~ /\A[A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z_][A-Za-z0-9_]*)*\z/;
    }
    if (($spec->{predicate}||0) eq 1) {
      $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
    }
    if (($spec->{clearer}||0) eq 1) {
      $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
    }
    if (($spec->{trigger}||0) eq 1) {
      $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
    }
  
    for my $setting (qw( isa coerce )) {
      next if !exists $spec->{$setting};
      $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
    }
  
    if (exists $spec->{default}) {
      if (!defined $spec->{default} || ref $spec->{default}) {
        $self->_validate_codulatable('default', $spec->{default}, "$into->$name", 'or a non-ref');
      }
    }
  
    if (exists $spec->{moosify}) {
      if (ref $spec->{moosify} ne 'ARRAY') {
        $spec->{moosify} = [$spec->{moosify}];
      }
  
      for my $spec (@{$spec->{moosify}}) {
        $self->_validate_codulatable('moosify', $spec, "$into->$name");
      }
    }
  
    my %methods;
    if (my $reader = $spec->{reader}) {
      _die_overwrite($into, $reader, 'a reader')
        if !$spec->{allow_overwrite} && *{_getglob("${into}::${reader}")}{CODE};
      if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
        $methods{$reader} = $self->_generate_xs(
          getters => $into, $reader, $name, $spec
        );
      } else {
        $self->{captures} = {};
        $methods{$reader} =
          quote_sub "${into}::${reader}"
            => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
               .$self->_generate_get($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $accessor = $spec->{accessor}) {
      _die_overwrite($into, $accessor, 'an accessor')
        if !$spec->{allow_overwrite} && *{_getglob("${into}::${accessor}")}{CODE};
      if (
        our $CAN_HAZ_XS
        && $self->is_simple_get($name, $spec)
        && $self->is_simple_set($name, $spec)
      ) {
        $methods{$accessor} = $self->_generate_xs(
          accessors => $into, $accessor, $name, $spec
        );
      } else {
        $self->{captures} = {};
        $methods{$accessor} =
          quote_sub "${into}::${accessor}"
            => $self->_generate_getset($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $writer = $spec->{writer}) {
      _die_overwrite($into, $writer, 'a writer')
        if !$spec->{allow_overwrite} && *{_getglob("${into}::${writer}")}{CODE};
      if (
        our $CAN_HAZ_XS
        && $self->is_simple_set($name, $spec)
      ) {
        $methods{$writer} = $self->_generate_xs(
          setters => $into, $writer, $name, $spec
        );
      } else {
        $self->{captures} = {};
        $methods{$writer} =
          quote_sub "${into}::${writer}"
            => $self->_generate_set($name, $spec)
            => delete $self->{captures}
          ;
      }
    }
    if (my $pred = $spec->{predicate}) {
      _die_overwrite($into, $pred, 'a predicate')
        if !$spec->{allow_overwrite} && *{_getglob("${into}::${pred}")}{CODE};
      $methods{$pred} =
        quote_sub "${into}::${pred}" =>
          '    '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
        ;
    }
    if (my $pred = $spec->{builder_sub}) {
      _install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} );
    }
    if (my $cl = $spec->{clearer}) {
      _die_overwrite($into, $cl, 'a clearer')
        if !$spec->{allow_overwrite} && *{_getglob("${into}::${cl}")}{CODE};
      $methods{$cl} =
        quote_sub "${into}::${cl}" => 
          $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
        ;
    }
    if (my $hspec = $spec->{handles}) {
      my $asserter = $spec->{asserter} ||= '_assert_'.$name;
      my @specs = do {
        if (ref($hspec) eq 'ARRAY') {
          map [ $_ => $_ ], @$hspec;
        } elsif (ref($hspec) eq 'HASH') {
          map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
            keys %$hspec;
        } elsif (!ref($hspec)) {
          map [ $_ => $_ ], use_module('Role::Tiny')->methods_provided_by(use_module($hspec))
        } else {
          die "You gave me a handles of ${hspec} and I have no idea why";
        }
      };
      foreach my $delegation_spec (@specs) {
        my ($proxy, $target, @args) = @$delegation_spec;
        _die_overwrite($into, $proxy, 'a delegation')
          if !$spec->{allow_overwrite} && *{_getglob("${into}::${proxy}")}{CODE};
        $self->{captures} = {};
        $methods{$proxy} =
          quote_sub "${into}::${proxy}" =>
            $self->_generate_delegation($asserter, $target, \@args),
            delete $self->{captures}
          ;
      }
    }
    if (my $asserter = $spec->{asserter}) {
      $self->{captures} = {};
  
  
      $methods{$asserter} =
        quote_sub "${into}::${asserter}" => $self->_generate_asserter($name, $spec),
          delete $self->{captures}
        ;
    }
    \%methods;
  }
  
  sub is_simple_attribute {
    my ($self, $name, $spec) = @_;
    # clearer doesn't have to be listed because it doesn't
    # affect whether defined/exists makes a difference
    !grep $spec->{$_},
      qw(lazy default builder coerce isa trigger predicate weak_ref);
  }
  
  sub is_simple_get {
    my ($self, $name, $spec) = @_;
    !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
  }
  
  sub is_simple_set {
    my ($self, $name, $spec) = @_;
    !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
  }
  
  sub has_eager_default {
    my ($self, $name, $spec) = @_;
    (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
  }
  
  sub _generate_get {
    my ($self, $name, $spec) = @_;
    my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
    if ($self->is_simple_get($name, $spec)) {
      $simple;
    } else {
      $self->_generate_use_default(
        '$_[0]', $name, $spec,
        $self->_generate_simple_has('$_[0]', $name, $spec),
      );
    }
  }
  
  sub generate_simple_has {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_simple_has(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_simple_has {
    my ($self, $me, $name) = @_;
    "exists ${me}->{${\perlstring $name}}";
  }
  
  sub _generate_simple_clear {
    my ($self, $me, $name) = @_;
    "    delete ${me}->{${\perlstring $name}}\n"
  }
  
  sub generate_get_default {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_get_default(@_);
    ($code, delete $self->{captures});
  }
  
  sub generate_use_default {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_use_default(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_use_default {
    my ($self, $me, $name, $spec, $test) = @_;
    my $get_value = $self->_generate_get_default($me, $name, $spec);
    if ($spec->{coerce}) {
      $get_value = $self->_generate_coerce(
        $name, $get_value,
        $spec->{coerce}
      )
    }
    $test." ? \n"
    .$self->_generate_simple_get($me, $name, $spec)."\n:"
    .($spec->{isa}
      ? "    do {\n      my \$value = ".$get_value.";\n"
        ."      ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
        ."      ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
        ."    }\n"
      : '    ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n");
  }
  
  sub _generate_get_default {
    my ($self, $me, $name, $spec) = @_;
    if (exists $spec->{default}) {
      ref $spec->{default}
        ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
        : perlstring $spec->{default};
    }
    else {
      "${me}->${\$spec->{builder}}"
    }
  }
  
  sub generate_simple_get {
    my ($self, @args) = @_;
    $self->_generate_simple_get(@args);
  }
  
  sub _generate_simple_get {
    my ($self, $me, $name) = @_;
    my $name_str = perlstring $name;
    "${me}->{${name_str}}";
  }
  
  sub _generate_set {
    my ($self, $name, $spec) = @_;
    if ($self->is_simple_set($name, $spec)) {
      $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
    } else {
      my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
      my $value_store = '$_[0]';
      my $code;
      if ($coerce) {
        $value_store = '$value';
        $code = "do { my (\$self, \$value) = \@_;\n"
          ."        \$value = "
          .$self->_generate_coerce($name, $value_store, $coerce).";\n";
      }
      else {
        $code = "do { my \$self = shift;\n";
      }
      if ($isa_check) {
        $code .= 
          "        ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n";
      }
      my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store);
      if ($trigger) {
        my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger);
        $code .=
          "        ".$simple.";\n        ".$fire.";\n"
          ."        $value_store;\n";
      } else {
        $code .= "        ".$simple.";\n";
      }
      $code .= "      }";
      $code;
    }
  }
  
  sub generate_coerce {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_coerce(@_);
    ($code, delete $self->{captures});
  }
  
  sub _attr_desc {
    my ($name, $init_arg) = @_;
    return perlstring($name) if !defined($init_arg) or $init_arg eq $name;
    return perlstring($name).' (constructor argument: '.perlstring($init_arg).')';
  }
  
  sub _generate_coerce {
    my ($self, $name, $value, $coerce, $init_arg) = @_;
    $self->_generate_die_prefix(
      $name,
      "coercion",
      $init_arg,
      $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
    );
  }
   
  sub generate_trigger {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_trigger(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_trigger {
    my ($self, $name, $obj, $value, $trigger) = @_;
    $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
  }
  
  sub generate_isa_check {
    my ($self, @args) = @_;
    $self->{captures} = {};
    my $code = $self->_generate_isa_check(@args);
    ($code, delete $self->{captures});
  }
  
  sub _generate_die_prefix {
    my ($self, $name, $prefix, $arg, $inside) = @_;
    "do {\n"
    .'  local $Method::Generate::Accessor::CurrentAttribute = {'
    .'    init_arg => '.(defined $arg ? B::perlstring($arg) : 'undef') . ",\n"
    .'    name     => '.B::perlstring($name).",\n"
    .'    step     => '.B::perlstring($prefix).",\n"
    ."  };\n"
    .'  local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n"
    .'  local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n"
    .$inside
    ."}\n"
  }
  
  sub _generate_isa_check {
    my ($self, $name, $value, $check, $init_arg) = @_;
    $self->_generate_die_prefix(
      $name,
      "isa check",
      $init_arg,
      $self->_generate_call_code($name, 'isa_check', $value, $check)
    );
  }
  
  sub _generate_call_code {
    my ($self, $name, $type, $values, $sub) = @_;
    $sub = \&{$sub} if blessed($sub);  # coderef if blessed
    if (my $quoted = quoted_from_sub($sub)) {
      my $local = 1;
      if ($values eq '@_' || $values eq '$_[0]') {
        $local = 0;
        $values = '@_';
      }
      my $code = $quoted->[1];
      if (my $captures = $quoted->[2]) {
        my $cap_name = qq{\$${type}_captures_for_${name}};
        $self->{captures}->{$cap_name} = \$captures;
        Sub::Quote::inlinify(
          $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), $local
        );
      } else {
        Sub::Quote::inlinify($code, $values, undef, $local);
      }
    } else {
      my $cap_name = qq{\$${type}_for_${name}};
      $self->{captures}->{$cap_name} = \$sub;
      "${cap_name}->(${values})";
    }
  }
  
  sub generate_populate_set {
    my $self = shift;
    $self->{captures} = {};
    my $code = $self->_generate_populate_set(@_);
    ($code, delete $self->{captures});
  }
  
  sub _generate_populate_set {
    my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
    if ($self->has_eager_default($name, $spec)) {
      my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
      my $get_default = $self->_generate_get_default(
                          '$new', $name, $spec
                        );
      my $get_value = 
        defined($spec->{init_arg})
          ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
              .$get_default
              ."\n${get_indent})"
          : $get_default;
      if ($spec->{coerce}) {
        $get_value = $self->_generate_coerce(
          $name, $get_value,
          $spec->{coerce}, $init_arg
        )
      }
      ($spec->{isa}
        ? "    {\n      my \$value = ".$get_value.";\n      "
          .$self->_generate_isa_check(
            $name, '$value', $spec->{isa}, $init_arg
          ).";\n"
          .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
          ."    }\n"
        : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
      )
      .($spec->{trigger}
        ? '    '
          .$self->_generate_trigger(
            $name, $me, $self->_generate_simple_get($me, $name, $spec),
            $spec->{trigger}
          )." if ${test};\n"
        : ''
      );
    } else {
      "    if (${test}) {\n"
        .($spec->{coerce}
          ? "      $source = "
            .$self->_generate_coerce(
              $name, $source,
              $spec->{coerce}, $init_arg
            ).";\n"
          : ""
        )
        .($spec->{isa}
          ? "      "
            .$self->_generate_isa_check(
              $name, $source, $spec->{isa}, $init_arg
            ).";\n"
          : ""
        )
        ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
        .($spec->{trigger}
          ? "      "
            .$self->_generate_trigger(
              $name, $me, $self->_generate_simple_get($me, $name, $spec),
              $spec->{trigger}
            ).";\n"
          : ""
        )
        ."    }\n";
    }
  }
  
  sub _generate_core_set {
    my ($self, $me, $name, $spec, $value) = @_;
    my $name_str = perlstring $name;
    "${me}->{${name_str}} = ${value}";
  }
  
  sub _generate_simple_set {
    my ($self, $me, $name, $spec, $value) = @_;
    my $name_str = perlstring $name;
    my $simple = $self->_generate_core_set($me, $name, $spec, $value);
  
    if ($spec->{weak_ref}) {
      require Scalar::Util;
      my $get = $self->_generate_simple_get($me, $name, $spec);
  
      # Perl < 5.8.3 can't weaken refs to readonly vars
      # (e.g. string constants). This *can* be solved by:
      #
      #Internals::SetReadWrite($foo);
      #Scalar::Util::weaken ($foo);
      #Internals::SetReadOnly($foo);
      #
      # but requires XS and is just too damn crazy
      # so simply throw a better exception
      my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }";
      Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
        eval { Scalar::Util::weaken($simple); 1 }
          ? do { no warnings 'void'; $get }
          : do {
            if( \$@ =~ /Modification of a read-only value attempted/) {
              require Carp;
              Carp::croak( sprintf (
                'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
                $name_str,
              ) );
            } else {
              die \$@;
            }
          }
  EOC
    } else {
      $simple;
    }
  }
  
  sub _generate_getset {
    my ($self, $name, $spec) = @_;
    q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
      ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
  }
  
  sub _generate_asserter {
    my ($self, $name, $spec) = @_;
  
    "do {\n"
     ."  my \$val = ".$self->_generate_get($name, $spec).";\n"
     ."  unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n"
     .qq!    die "Attempted to access '${name}' but it is not set";\n!
     ."  }\n"
     ."  \$val;\n"
     ."}\n";
  }
  sub _generate_delegation {
    my ($self, $asserter, $target, $args) = @_;
    my $arg_string = do {
      if (@$args) {
        # I could, I reckon, linearise out non-refs here using perlstring
        # plus something to check for numbers but I'm unsure if it's worth it
        $self->{captures}{'@curries'} = $args;
        '@curries, @_';
      } else {
        '@_';
      }
    };
    "shift->${asserter}->${target}(${arg_string});";
  }
  
  sub _generate_xs {
    my ($self, $type, $into, $name, $slot) = @_;
    Class::XSAccessor->import(
      class => $into,
      $type => { $name => $slot },
      replace => 1,
    );
    $into->can($name);
  }
  
  sub default_construction_string { '{}' }
  
  sub _validate_codulatable {
    my ($self, $setting, $value, $into, $appended) = @_;
    my $invalid = "Invalid $setting '" . overload::StrVal($value)
      . "' for $into not a coderef";
    $invalid .= " $appended" if $appended;
  
    unless (ref $value and (ref $value eq 'CODE' or blessed($value))) {
      die "$invalid or code-convertible object";
    }
  
    unless (eval { \&$value }) {
      die "$invalid and could not be converted to a coderef: $@";
    }
  
    1;
  }
  
  1;
METHOD_GENERATE_ACCESSOR

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

$fatpacked{"Method/Generate/Constructor.pm"} = <<'METHOD_GENERATE_CONSTRUCTOR';
  package Method::Generate::Constructor;
  
  use strictures 1;
  use Sub::Quote;
  use base qw(Moo::Object);
  use Sub::Defer;
  use B 'perlstring';
  use Moo::_Utils qw(_getstash);
  
  sub register_attribute_specs {
    my ($self, @new_specs) = @_;
    my $specs = $self->{attribute_specs}||={};
    while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
      if ($name =~ s/^\+//) {
        die "has '+${name}' given but no ${name} attribute already exists"
          unless my $old_spec = $specs->{$name};
        foreach my $key (keys %$old_spec) {
          if (!exists $new_spec->{$key}) {
            $new_spec->{$key} = $old_spec->{$key}
              unless $key eq 'handles';
          }
          elsif ($key eq 'moosify') {
            $new_spec->{$key} = [
              map { ref $_ eq 'ARRAY' ? @$_ : $_ }
                ($old_spec->{$key}, $new_spec->{$key})
            ];
          }
        }
      }
      $new_spec->{index} = scalar keys %$specs
        unless defined $new_spec->{index};
      $specs->{$name} = $new_spec;
    }
    $self;
  }
  
  sub all_attribute_specs {
    $_[0]->{attribute_specs}
  }
  
  sub accessor_generator {
    $_[0]->{accessor_generator}
  }
  
  sub construction_string {
    my ($self) = @_;
    $self->{construction_string}
      ||= $self->_build_construction_string;
  }
  
  sub _build_construction_string {
    'bless('
      .$_[0]->accessor_generator->default_construction_string
      .', $class);'
  }
  
  sub install_delayed {
    my ($self) = @_;
    my $package = $self->{package};
    defer_sub "${package}::new" => sub {
      unquote_sub $self->generate_method(
        $package, 'new', $self->{attribute_specs}, { no_install => 1 }
      )
    };
    $self;
  }
  
  sub generate_method {
    my ($self, $into, $name, $spec, $quote_opts) = @_;
    foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
      $spec->{$no_init}{init_arg} = $no_init;
    }
    local $self->{captures} = {};
    my $body = '    my $class = shift;'."\n"
              .'    $class = ref($class) if ref($class);'."\n";
    $body .= $self->_handle_subconstructor($into, $name);
    my $into_buildargs = $into->can('BUILDARGS');
    if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) {
        $body .= $self->_generate_args_via_buildargs;
    } else {
        $body .= $self->_generate_args;
    }
    $body .= $self->_check_required($spec);
    $body .= '    my $new = '.$self->construction_string.";\n";
    $body .= $self->_assign_new($spec);
    if ($into->can('BUILD')) {
      require Method::Generate::BuildAll;
      $body .= Method::Generate::BuildAll->new->buildall_body_for(
        $into, '$new', '$args'
      );
    }
    $body .= '    return $new;'."\n";
    if ($into->can('DEMOLISH')) {
      require Method::Generate::DemolishAll;
      Method::Generate::DemolishAll->new->generate_method($into);
    }
    quote_sub
      "${into}::${name}" => $body,
      $self->{captures}, $quote_opts||{}
    ;
  }
  
  sub _handle_subconstructor {
    my ($self, $into, $name) = @_;
    if (my $gen = $self->{subconstructor_handler}) {
      '    if ($class ne '.perlstring($into).') {'."\n".
      $gen.
      '    }'."\n";
    } else {
      ''
    }
  }
  
  sub _cap_call {
    my ($self, $code, $captures) = @_;
    @{$self->{captures}}{keys %$captures} = values %$captures if $captures;
    $code;
  }
  
  sub _generate_args_via_buildargs {
    my ($self) = @_;
    q{    my $args = $class->BUILDARGS(@_);}."\n"
    .q{    die "BUILDARGS did not return a hashref" unless ref($args) eq 'HASH';}
    ."\n";
  }
  
  # inlined from Moo::Object - update that first.
  sub _generate_args {
    my ($self) = @_;
    return <<'_EOA';
      my $args;
      if ( scalar @_ == 1 ) {
          unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
              die "Single parameters to new() must be a HASH ref"
                  ." data => ". $_[0] ."\n";
          }
          $args = { %{ $_[0] } };
      }
      elsif ( @_ % 2 ) {
          die "The new() method for $class expects a hash reference or a key/value list."
                  . " You passed an odd number of arguments\n";
      }
      else {
          $args = {@_};
      }
  _EOA
  
  }
  
  sub _assign_new {
    my ($self, $spec) = @_;
    my $ag = $self->accessor_generator;
    my %test;
    NAME: foreach my $name (sort keys %$spec) {
      my $attr_spec = $spec->{$name};
      next NAME unless defined($attr_spec->{init_arg})
                         or $ag->has_eager_default($name, $attr_spec);
      $test{$name} = $attr_spec->{init_arg};
    }
    join '', map {
      my $arg_key = perlstring($test{$_});
      my $test = "exists \$args->{$arg_key}";
      my $source = "\$args->{$arg_key}";
      my $attr_spec = $spec->{$_};
      $self->_cap_call($ag->generate_populate_set(
        '$new', $_, $attr_spec, $source, $test, $test{$_},
      ));
    } sort keys %test;
  }
  
  sub _check_required {
    my ($self, $spec) = @_;
    my @required_init =
      map $spec->{$_}{init_arg},
        grep {
          my %s = %{$spec->{$_}}; # ignore required if default or builder set
          $s{required} and not($s{builder} or $s{default})
        } sort keys %$spec;
    return '' unless @required_init;
    '    if (my @missing = grep !exists $args->{$_}, qw('
      .join(' ',@required_init).')) {'."\n"
      .q{      die "Missing required arguments: ".join(', ', sort @missing);}."\n"
      ."    }\n";
  }
  
  use Moo;
  Moo->_constructor_maker_for(__PACKAGE__)->register_attribute_specs(
    attribute_specs => {
      is => 'ro',
      reader => 'all_attribute_specs',
    },
    accessor_generator => { is => 'ro' },
    construction_string => { is => 'lazy' },
    subconstructor_handler => { is => 'ro' },
    package => { is => 'ro' },
  );
  
  1;
METHOD_GENERATE_CONSTRUCTOR

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

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

$fatpacked{"Module/Implementation.pm"} = <<'MODULE_IMPLEMENTATION';
  package Module::Implementation;
  {
    $Module::Implementation::VERSION = '0.06';
  }
  
  use strict;
  use warnings;
  
  use Module::Runtime 0.012 qw( require_module );
  use Try::Tiny;
  
  my %Implementation;
  
  sub build_loader_sub {
      my $caller = caller();
  
      return _build_loader( $caller, @_ );
  }
  
  sub _build_loader {
      my $package = shift;
      my %args    = @_;
  
      my @implementations = @{ $args{implementations} };
      my @symbols = @{ $args{symbols} || [] };
  
      my $implementation;
      my $env_var = uc $package;
      $env_var =~ s/::/_/g;
      $env_var .= '_IMPLEMENTATION';
  
      return sub {
          my ( $implementation, $loaded ) = _load_implementation(
              $package,
              $ENV{$env_var},
              \@implementations,
          );
  
          $Implementation{$package} = $implementation;
  
          _copy_symbols( $loaded, $package, \@symbols );
  
          return $loaded;
      };
  }
  
  sub implementation_for {
      my $package = shift;
  
      return $Implementation{$package};
  }
  
  sub _load_implementation {
      my $package         = shift;
      my $env_value       = shift;
      my $implementations = shift;
  
      if ($env_value) {
          die "$env_value is not a valid implementation for $package"
              unless grep { $_ eq $env_value } @{$implementations};
  
          my $loaded = "${package}::$env_value";
  
          # Values from the %ENV hash are tainted. We know it's safe to untaint
          # this value because the value was one of our known implementations.
          ($loaded) = $loaded =~ /^(.+)$/;
  
          try {
              require_module($loaded);
          }
          catch {
              require Carp;
              Carp::croak("Could not load $loaded: $_");
          };
  
          return ( $env_value, $loaded );
      }
      else {
          my $err;
          for my $possible ( @{$implementations} ) {
              my $load = "${package}::$possible";
  
              my $ok;
              try {
                  require_module($load);
                  $ok = 1;
              }
              catch {
                  $err .= $_;
              };
  
              return ( $possible, $load ) if $ok;
          }
  
          require Carp;
          Carp::croak(
              "Could not find a suitable $package implementation: $err");
      }
  }
  
  sub _copy_symbols {
      my $from_package = shift;
      my $to_package   = shift;
      my $symbols      = shift;
  
      for my $sym ( @{$symbols} ) {
          my $type = $sym =~ s/^([\$\@\%\&\*])// ? $1 : '&';
  
          my $from = "${from_package}::$sym";
          my $to   = "${to_package}::$sym";
  
          {
              no strict 'refs';
              no warnings 'once';
  
              # Copied from Exporter
              *{$to}
                  = $type eq '&' ? \&{$from}
                  : $type eq '$' ? \${$from}
                  : $type eq '@' ? \@{$from}
                  : $type eq '%' ? \%{$from}
                  : $type eq '*' ? *{$from}
                  : die
                  "Can't copy symbol from $from_package to $to_package: $type$sym";
          }
      }
  }
  
  1;
  
  # ABSTRACT: Loads one of several alternate underlying implementations for a module
  
  
  
  =pod
  
  =head1 NAME
  
  Module::Implementation - Loads one of several alternate underlying implementations for a module
  
  =head1 VERSION
  
  version 0.06
  
  =head1 SYNOPSIS
  
    package Foo::Bar;
  
    use Module::Implementation;
  
    BEGIN {
        my $loader = Module::Implementation::build_loader_sub(
            implementations => [ 'XS',  'PurePerl' ],
            symbols         => [ 'run', 'check' ],
        );
  
        $loader->();
    }
  
    package Consumer;
  
    # loads the first viable implementation
    use Foo::Bar;
  
  =head1 DESCRIPTION
  
  This module abstracts out the process of choosing one of several underlying
  implementations for a module. This can be used to provide XS and pure Perl
  implementations of a module, or it could be used to load an implementation for
  a given OS or any other case of needing to provide multiple implementations.
  
  This module is only useful when you know all the implementations ahead of
  time. If you want to load arbitrary implementations then you probably want
  something like a plugin system, not this module.
  
  =head1 API
  
  This module provides two subroutines, neither of which are exported.
  
  =head2 Module::Implementation::<build_loader_sub(...)
  
  This subroutine takes the following arguments.
  
  =over 4
  
  =item * implementations
  
  This should be an array reference of implementation names. Each name should
  correspond to a module in the caller's namespace.
  
  In other words, using the example in the L</SYNOPSIS>, this module will look
  for the C<Foo::Bar::XS> and C<Foo::Bar::PurePerl> modules will be installed
  
  This argument is required.
  
  =item * symbols
  
  A list of symbols to copy from the implementation package to the calling
  package.
  
  These can be prefixed with a variable type: C<$>, C<@>, C<%>, C<&>, or
  C<*)>. If no prefix is given, the symbol is assumed to be a subroutine.
  
  This argument is optional.
  
  =back
  
  This subroutine I<returns> the implementation loader as a sub reference.
  
  It is up to you to call this loader sub in your code.
  
  I recommend that you I<do not> call this loader in an C<import()> sub. If a
  caller explicitly requests no imports, your C<import()> sub will not be run at
  all, which can cause weird breakage.
  
  =head2 Module::Implementation::implementation_for($package)
  
  Given a package name, this subroutine returns the implementation that was
  loaded for the package. This is not a full package name, just the suffix that
  identifies the implementation. For the L</SYNOPSIS> example, this subroutine
  would be called as C<Module::Implementation::implementation_for('Foo::Bar')>,
  and it would return "XS" or "PurePerl".
  
  =head1 HOW THE IMPLEMENTATION LOADER WORKS
  
  The implementation loader works like this ...
  
  First, it checks for an C<%ENV> var specifying the implementation to load. The
  env var is based on the package name which loads the implementations. The
  C<::> package separator is replaced with C<_>, and made entirely
  upper-case. Finally, we append "_IMPLEMENTATION" to this name.
  
  So in our L</SYNOPSIS> example, the corresponding C<%ENV> key would be
  C<FOO_BAR_IMPLEMENTATION>.
  
  If this is set, then the loader will B<only> try to load this one
  implementation.
  
  If the env var requests an implementation which doesn't match one of the
  implementations specified when the loader was created, an error is thrown.
  
  If this one implementation fails to load then loader throws an error. This is
  useful for testing. You can request a specific implementation in a test file
  by writing something like this:
  
    BEGIN { $ENV{FOO_BAR_IMPLEMENTATION} = 'XS' }
    use Foo::Bar;
  
  If the environment variable is I<not> set, then the loader simply tries the
  implementations originally passed to C<Module::Implementation>. The
  implementations are tried in the order in which they were originally passed.
  
  The loader will use the first implementation that loads without an error. It
  will copy any requested symbols from this implementation.
  
  If none of the implementations can be loaded, then the loader throws an
  exception.
  
  The loader returns the name of the package it loaded.
  
  =head1 AUTHOR
  
  Dave Rolsky <autarch@urth.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2012 by Dave Rolsky.
  
  This is free software, licensed under:
  
    The Artistic License 2.0 (GPL Compatible)
  
  =cut
  
  
  __END__
  
MODULE_IMPLEMENTATION

$fatpacked{"Module/Runtime.pm"} = <<'MODULE_RUNTIME';
  =head1 NAME
  
  Module::Runtime - runtime module handling
  
  =head1 SYNOPSIS
  
  	use Module::Runtime qw(
  		$module_name_rx is_module_name check_module_name
  		module_notional_filename require_module
  	);
  
  	if($module_name =~ /\A$module_name_rx\z/o) { ...
  	if(is_module_name($module_name)) { ...
  	check_module_name($module_name);
  
  	$notional_filename = module_notional_filename($module_name);
  	require_module($module_name);
  
  	use Module::Runtime qw(use_module use_package_optimistically);
  
  	$bi = use_module("Math::BigInt", 1.31)->new("1_234");
  	$widget = use_package_optimistically("Local::Widget")->new;
  
  	use Module::Runtime qw(
  		$top_module_spec_rx $sub_module_spec_rx
  		is_module_spec check_module_spec
  		compose_module_name
  	);
  
  	if($spec =~ /\A$top_module_spec_rx\z/o) { ...
  	if($spec =~ /\A$sub_module_spec_rx\z/o) { ...
  	if(is_module_spec("Standard::Prefix", $spec)) { ...
  	check_module_spec("Standard::Prefix", $spec);
  
  	$module_name =
  		compose_module_name("Standard::Prefix", $spec);
  
  =head1 DESCRIPTION
  
  The functions exported by this module deal with runtime handling of
  Perl modules, which are normally handled at compile time.  This module
  avoids using any other modules, so that it can be used in low-level
  infrastructure.
  
  The parts of this module that work with module names apply the same
  syntax that is used for barewords in Perl source.  In principle this
  syntax can vary between versions of Perl, and this module applies the
  syntax of the Perl on which it is running.  In practice the usable syntax
  hasn't changed yet, but there's a good chance of it changing in Perl 5.18.
  
  The functions of this module whose purpose is to load modules include
  workarounds for three old Perl core bugs regarding C<require>.  These
  workarounds are applied on any Perl version where the bugs exist, except
  for a case where one of the bugs cannot be adequately worked around in
  pure Perl.
  
  =head2 Module name syntax
  
  The usable module name syntax has not changed from Perl 5.000 up to
  Perl 5.15.7.  The syntax is composed entirely of ASCII characters.
  From Perl 5.6 onwards there has been some attempt to allow the use of
  non-ASCII Unicode characters in Perl source, but it was fundamentally
  broken (like the entirety of Perl 5.6's Unicode handling) and remained
  pretty much entirely unusable until it got some attention in the Perl
  5.15 series.  Although Unicode is now consistently accepted by the
  parser in some places, it remains broken for module names.  Furthermore,
  there has not yet been any work on how to map Unicode module names into
  filenames, so in that respect also Unicode module names are unusable.
  This may finally be addressed in the Perl 5.17 series.
  
  The module name syntax is, precisely: the string must consist of one or
  more segments separated by C<::>; each segment must consist of one or more
  identifier characters (ASCII alphanumerics plus "_"); the first character
  of the string must not be a digit.  Thus "C<IO::File>", "C<warnings>",
  and "C<foo::123::x_0>" are all valid module names, whereas "C<IO::>"
  and "C<1foo::bar>" are not.  C<'> separators are not permitted by this
  module, though they remain usable in Perl source, being translated to
  C<::> in the parser.
  
  =head2 Core bugs worked around
  
  The first bug worked around is core bug [perl #68590], which causes
  lexical state in one file to leak into another that is C<require>d/C<use>d
  from it.  This bug is present from Perl 5.6 up to Perl 5.10, and is
  fixed in Perl 5.11.0.  From Perl 5.9.4 up to Perl 5.10.0 no satisfactory
  workaround is possible in pure Perl.  The workaround means that modules
  loaded via this module don't suffer this pollution of their lexical
  state.  Modules loaded in other ways, or via this module on the Perl
  versions where the pure Perl workaround is impossible, remain vulnerable.
  The module L<Lexical::SealRequireHints> provides a complete workaround
  for this bug.
  
  The second bug worked around causes some kinds of failure in module
  loading, principally compilation errors in the loaded module, to be
  recorded in C<%INC> as if they were successful, so later attempts to load
  the same module immediately indicate success.  This bug is present up
  to Perl 5.8.9, and is fixed in Perl 5.9.0.  The workaround means that a
  compilation error in a module loaded via this module won't be cached as
  a success.  Modules loaded in other ways remain liable to produce bogus
  C<%INC> entries, and if a bogus entry exists then it will mislead this
  module if it is used to re-attempt loading.
  
  The third bug worked around causes the wrong context to be seen at
  file scope of a loaded module, if C<require> is invoked in a location
  that inherits context from a higher scope.  This bug is present up to
  Perl 5.11.2, and is fixed in Perl 5.11.3.  The workaround means that
  a module loaded via this module will always see the correct context.
  Modules loaded in other ways remain vulnerable.
  
  =cut
  
  package Module::Runtime;
  
  # Don't "use 5.006" here, because Perl 5.15.6 will load feature.pm if
  # the version check is done that way.
  BEGIN { require 5.006; }
  # Don't "use warnings" here, to avoid dependencies.  Do standardise the
  # warning status by lexical override; unfortunately the only safe bitset
  # to build in is the empty set, equivalent to "no warnings".
  BEGIN { ${^WARNING_BITS} = ""; }
  # Don't "use strict" here, to avoid dependencies.
  
  our $VERSION = "0.013";
  
  # Don't use Exporter here, to avoid dependencies.
  our @EXPORT_OK = qw(
  	$module_name_rx is_module_name is_valid_module_name check_module_name
  	module_notional_filename require_module
  	use_module use_package_optimistically
  	$top_module_spec_rx $sub_module_spec_rx
  	is_module_spec is_valid_module_spec check_module_spec
  	compose_module_name
  );
  my %export_ok = map { ($_ => undef) } @EXPORT_OK;
  sub import {
  	my $me = shift;
  	my $callpkg = caller(0);
  	my $errs = "";
  	foreach(@_) {
  		if(exists $export_ok{$_}) {
  			# We would need to do "no strict 'refs'" here
  			# if we had enabled strict at file scope.
  			if(/\A\$(.*)\z/s) {
  				*{$callpkg."::".$1} = \$$1;
  			} else {
  				*{$callpkg."::".$_} = \&$_;
  			}
  		} else {
  			$errs .= "\"$_\" is not exported by the $me module\n";
  		}
  	}
  	if($errs ne "") {
  		die "${errs}Can't continue after import errors ".
  			"at @{[(caller(0))[1]]} line @{[(caller(0))[2]]}.\n";
  	}
  }
  
  # Logic duplicated from Params::Classify.  Duplicating it here avoids
  # an extensive and potentially circular dependency graph.
  sub _is_string($) {
  	my($arg) = @_;
  	return defined($arg) && ref(\$arg) eq "SCALAR";
  }
  
  =head1 REGULAR EXPRESSIONS
  
  These regular expressions do not include any anchors, so to check
  whether an entire string matches a syntax item you must supply the
  anchors yourself.
  
  =over
  
  =item $module_name_rx
  
  Matches a valid Perl module name in bareword syntax.
  
  =cut
  
  our $module_name_rx = qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/;
  
  =item $top_module_spec_rx
  
  Matches a module specification for use with L</compose_module_name>,
  where no prefix is being used.
  
  =cut
  
  my $qual_module_spec_rx =
  	qr#(?:/|::)[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;
  
  my $unqual_top_module_spec_rx =
  	qr#[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;
  
  our $top_module_spec_rx = qr/$qual_module_spec_rx|$unqual_top_module_spec_rx/o;
  
  =item $sub_module_spec_rx
  
  Matches a module specification for use with L</compose_module_name>,
  where a prefix is being used.
  
  =cut
  
  my $unqual_sub_module_spec_rx = qr#[0-9A-Z_a-z]+(?:(?:/|::)[0-9A-Z_a-z]+)*#;
  
  our $sub_module_spec_rx = qr/$qual_module_spec_rx|$unqual_sub_module_spec_rx/o;
  
  =back
  
  =head1 FUNCTIONS
  
  =head2 Basic module handling
  
  =over
  
  =item is_module_name(ARG)
  
  Returns a truth value indicating whether I<ARG> is a plain string
  satisfying Perl module name syntax as described for L</$module_name_rx>.
  
  =cut
  
  sub is_module_name($) { _is_string($_[0]) && $_[0] =~ /\A$module_name_rx\z/o }
  
  =item is_valid_module_name(ARG)
  
  Deprecated alias for L</is_module_name>.
  
  =cut
  
  *is_valid_module_name = \&is_module_name;
  
  =item check_module_name(ARG)
  
  Check whether I<ARG> is a plain string
  satisfying Perl module name syntax as described for L</$module_name_rx>.
  Return normally if it is, or C<die> if it is not.
  
  =cut
  
  sub check_module_name($) {
  	unless(&is_module_name) {
  		die +(_is_string($_[0]) ? "`$_[0]'" : "argument").
  			" is not a module name\n";
  	}
  }
  
  =item module_notional_filename(NAME)
  
  Generates a notional relative filename for a module, which is used in
  some Perl core interfaces.
  The I<NAME> is a string, which should be a valid module name (one or
  more C<::>-separated segments).  If it is not a valid name, the function
  C<die>s.
  
  The notional filename for the named module is generated and returned.
  This filename is always in Unix style, with C</> directory separators
  and a C<.pm> suffix.  This kind of filename can be used as an argument to
  C<require>, and is the key that appears in C<%INC> to identify a module,
  regardless of actual local filename syntax.
  
  =cut
  
  sub module_notional_filename($) {
  	&check_module_name;
  	my($name) = @_;
  	$name =~ s!::!/!g;
  	return $name.".pm";
  }
  
  =item require_module(NAME)
  
  This is essentially the bareword form of C<require>, in runtime form.
  The I<NAME> is a string, which should be a valid module name (one or
  more C<::>-separated segments).  If it is not a valid name, the function
  C<die>s.
  
  The module specified by I<NAME> is loaded, if it hasn't been already,
  in the manner of the bareword form of C<require>.  That means that a
  search through C<@INC> is performed, and a byte-compiled form of the
  module will be used if available.
  
  The return value is as for C<require>.  That is, it is the value returned
  by the module itself if the module is loaded anew, or C<1> if the module
  was already loaded.
  
  =cut
  
  # Don't "use constant" here, to avoid dependencies.
  BEGIN {
  	*_WORK_AROUND_HINT_LEAKAGE =
  		"$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
  			? sub(){1} : sub(){0};
  	*_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0};
  }
  
  BEGIN { if(_WORK_AROUND_BROKEN_MODULE_STATE) { eval q{
  	sub Module::Runtime::__GUARD__::DESTROY {
  		delete $INC{$_[0]->[0]} if @{$_[0]};
  	}
  	1;
  }; die $@ if $@ ne ""; } }
  
  sub require_module($) {
  	# Localise %^H to work around [perl #68590], where the bug exists
  	# and this is a satisfactory workaround.  The bug consists of
  	# %^H state leaking into each required module, polluting the
  	# module's lexical state.
  	local %^H if _WORK_AROUND_HINT_LEAKAGE;
  	if(_WORK_AROUND_BROKEN_MODULE_STATE) {
  		my $notional_filename = &module_notional_filename;
  		my $guard = bless([ $notional_filename ],
  				"Module::Runtime::__GUARD__");
  		my $result = require($notional_filename);
  		pop @$guard;
  		return $result;
  	} else {
  		return scalar(require(&module_notional_filename));
  	}
  }
  
  =back
  
  =head2 Structured module use
  
  =over
  
  =item use_module(NAME[, VERSION])
  
  This is essentially C<use> in runtime form, but without the importing
  feature (which is fundamentally a compile-time thing).  The I<NAME> is
  handled just like in C<require_module> above: it must be a module name,
  and the named module is loaded as if by the bareword form of C<require>.
  
  If a I<VERSION> is specified, the C<VERSION> method of the loaded module is
  called with the specified I<VERSION> as an argument.  This normally serves to
  ensure that the version loaded is at least the version required.  This is
  the same functionality provided by the I<VERSION> parameter of C<use>.
  
  On success, the name of the module is returned.  This is unlike
  L</require_module>, and is done so that the entire call to L</use_module>
  can be used as a class name to call a constructor, as in the example in
  the synopsis.
  
  =cut
  
  sub use_module($;$) {
  	my($name, $version) = @_;
  	require_module($name);
  	if(defined $version) {
  		$name->VERSION($version);
  	}
  	return $name;
  }
  
  =item use_package_optimistically(NAME[, VERSION])
  
  This is an analogue of L</use_module> for the situation where there is
  uncertainty as to whether a package/class is defined in its own module
  or by some other means.  It attempts to arrange for the named package to
  be available, either by loading a module or by doing nothing and hoping.
  
  An attempt is made to load the named module (as if by the bareword form
  of C<require>).  If the module cannot be found then it is assumed that
  the package was actually already loaded by other means, and no error
  is signalled.  That's the optimistic bit.
  
  This is mostly the same operation that is performed by the L<base> pragma
  to ensure that the specified base classes are available.  The behaviour
  of L<base> was simplified in version 2.18, and this function changed
  to match.
  
  If a I<VERSION> is specified, the C<VERSION> method of the loaded package is
  called with the specified I<VERSION> as an argument.  This normally serves
  to ensure that the version loaded is at least the version required.
  On success, the name of the package is returned.  These aspects of the
  function work just like L</use_module>.
  
  =cut
  
  sub use_package_optimistically($;$) {
  	my($name, $version) = @_;
  	check_module_name($name);
  	eval { local $SIG{__DIE__}; require_module($name); };
  	die $@ if $@ ne "" &&
  		$@ !~ /\ACan't locate .+ at \Q@{[__FILE__]}\E line/s;
  	$name->VERSION($version) if defined $version;
  	return $name;
  }
  
  =back
  
  =head2 Module name composition
  
  =over
  
  =item is_module_spec(PREFIX, SPEC)
  
  Returns a truth value indicating
  whether I<SPEC> is valid input for L</compose_module_name>.
  See below for what that entails.  Whether a I<PREFIX> is supplied affects
  the validity of I<SPEC>, but the exact value of the prefix is unimportant,
  so this function treats I<PREFIX> as a truth value.
  
  =cut
  
  sub is_module_spec($$) {
  	my($prefix, $spec) = @_;
  	return _is_string($spec) &&
  		$spec =~ ($prefix ? qr/\A$sub_module_spec_rx\z/o :
  				    qr/\A$top_module_spec_rx\z/o);
  }
  
  =item is_valid_module_spec(PREFIX, SPEC)
  
  Deprecated alias for L</is_module_spec>.
  
  =cut
  
  *is_valid_module_spec = \&is_module_spec;
  
  =item check_module_spec(PREFIX, SPEC)
  
  Check whether I<SPEC> is valid input for L</compose_module_name>.
  Return normally if it is, or C<die> if it is not.
  
  =cut
  
  sub check_module_spec($$) {
  	unless(&is_module_spec) {
  		die +(_is_string($_[1]) ? "`$_[1]'" : "argument").
  			" is not a module specification\n";
  	}
  }
  
  =item compose_module_name(PREFIX, SPEC)
  
  This function is intended to make it more convenient for a user to specify
  a Perl module name at runtime.  Users have greater need for abbreviations
  and context-sensitivity than programmers, and Perl module names get a
  little unwieldy.  I<SPEC> is what the user specifies, and this function
  translates it into a module name in standard form, which it returns.
  
  I<SPEC> has syntax approximately that of a standard module name: it
  should consist of one or more name segments, each of which consists
  of one or more identifier characters.  However, C</> is permitted as a
  separator, in addition to the standard C<::>.  The two separators are
  entirely interchangeable.
  
  Additionally, if I<PREFIX> is not C<undef> then it must be a module
  name in standard form, and it is prefixed to the user-specified name.
  The user can inhibit the prefix addition by starting I<SPEC> with a
  separator (either C</> or C<::>).
  
  =cut
  
  sub compose_module_name($$) {
  	my($prefix, $spec) = @_;
  	check_module_name($prefix) if defined $prefix;
  	&check_module_spec;
  	if($spec =~ s#\A(?:/|::)##) {
  		# OK
  	} else {
  		$spec = $prefix."::".$spec if defined $prefix;
  	}
  	$spec =~ s#/#::#g;
  	return $spec;
  }
  
  =back
  
  =head1 SEE ALSO
  
  L<Lexical::SealRequireHints>,
  L<base>,
  L<perlfunc/require>,
  L<perlfunc/use>
  
  =head1 AUTHOR
  
  Andrew Main (Zefram) <zefram@fysh.org>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2004, 2006, 2007, 2009, 2010, 2011, 2012
  Andrew Main (Zefram) <zefram@fysh.org>
  
  =head1 LICENSE
  
  This module is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =cut
  
  1;
MODULE_RUNTIME

$fatpacked{"Moo.pm"} = <<'MOO';
  package Moo;
  
  use strictures 1;
  use Moo::_Utils;
  use B 'perlstring';
  use Sub::Defer ();
  
  our $VERSION = '1.003000'; # 1.3.0
  $VERSION = eval $VERSION;
  
  require Moo::sification;
  
  our %MAKERS;
  
  sub _install_tracked {
    my ($target, $name, $code) = @_;
    $MAKERS{$target}{exports}{$name} = $code;
    _install_coderef "${target}::${name}" => "Moo::${name}" => $code;
  }
  
  sub import {
    my $target = caller;
    my $class = shift;
    strictures->import;
    if ($Role::Tiny::INFO{$target} and $Role::Tiny::INFO{$target}{is_role}) {
      die "Cannot import Moo into a role";
    }
    $MAKERS{$target} ||= {};
    _install_tracked $target => extends => sub {
      $class->_set_superclasses($target, @_);
      $class->_maybe_reset_handlemoose($target);
      return;
    };
    _install_tracked $target => with => sub {
      require Moo::Role;
      Moo::Role->apply_roles_to_package($target, @_);
      $class->_maybe_reset_handlemoose($target);
    };
    _install_tracked $target => has => sub {
      my ($name_proto, %spec) = @_;
      my $name_isref = ref $name_proto eq 'ARRAY';
      foreach my $name ($name_isref ? @$name_proto : $name_proto) {
        # Note that when $name_proto is an arrayref, each attribute
        # needs a separate \%specs hashref
        my $spec_ref = $name_isref ? +{%spec} : \%spec;
        $class->_constructor_maker_for($target)
              ->register_attribute_specs($name, $spec_ref);
        $class->_accessor_maker_for($target)
              ->generate_method($target, $name, $spec_ref);
        $class->_maybe_reset_handlemoose($target);
      }
      return;
    };
    foreach my $type (qw(before after around)) {
      _install_tracked $target => $type => sub {
        require Class::Method::Modifiers;
        _install_modifier($target, $type, @_);
        return;
      };
    }
    return if $MAKERS{$target}{is_class}; # already exported into this package
    $MAKERS{$target}{is_class} = 1;
    {
      no strict 'refs';
      @{"${target}::ISA"} = do {
        require Moo::Object; ('Moo::Object');
      } unless @{"${target}::ISA"};
    }
    if ($INC{'Moo/HandleMoose.pm'}) {
      Moo::HandleMoose::inject_fake_metaclass_for($target);
    }
  }
  
  sub unimport {
    my $target = caller;
    _unimport_coderefs($target, $MAKERS{$target});
  }
  
  sub _set_superclasses {
    my $class = shift;
    my $target = shift;
    foreach my $superclass (@_) {
      _load_module($superclass);
      if ($INC{"Role/Tiny.pm"} && $Role::Tiny::INFO{$superclass}) {
        require Carp;
        Carp::croak("Can't extend role '$superclass'");
      }
    }
    # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
    @{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
    if (my $old = delete $Moo::MAKERS{$target}{constructor}) {
      delete _getstash($target)->{new};
      Moo->_constructor_maker_for($target)
         ->register_attribute_specs(%{$old->all_attribute_specs});
    }
    elsif (!$target->isa('Moo::Object')) {
      Moo->_constructor_maker_for($target);
    }
    no warnings 'once'; # piss off. -- mst
    $Moo::HandleMoose::MOUSE{$target} = [
      grep defined, map Mouse::Util::find_meta($_), @_
    ] if Mouse::Util->can('find_meta');
  }
  
  sub _maybe_reset_handlemoose {
    my ($class, $target) = @_;
    if ($INC{"Moo/HandleMoose.pm"}) {
      Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
    }
  }
  
  sub _accessor_maker_for {
    my ($class, $target) = @_;
    return unless $MAKERS{$target};
    $MAKERS{$target}{accessor} ||= do {
      my $maker_class = do {
        if (my $m = do {
              if (my $defer_target = 
                    (Sub::Defer::defer_info($target->can('new'))||[])->[0]
                ) {
                my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
                $MAKERS{$pkg} && $MAKERS{$pkg}{accessor};
              } else {
                undef;
              }
            }) {
          ref($m);
        } else {
          require Method::Generate::Accessor;
          'Method::Generate::Accessor'
        }
      };
      $maker_class->new;
    }
  }
  
  sub _constructor_maker_for {
    my ($class, $target) = @_;
    return unless $MAKERS{$target};
    $MAKERS{$target}{constructor} ||= do {
      require Method::Generate::Constructor;
      require Sub::Defer;
      my ($moo_constructor, $con);
  
      my $t_new = $target->can('new');
      if ($t_new) {
        if ($t_new == Moo::Object->can('new')) {
          $moo_constructor = 1;
        } elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) {
          my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
          if ($MAKERS{$pkg}) {
            $moo_constructor = 1;
            $con = $MAKERS{$pkg}{constructor};
          }
        }
      } else {
        $moo_constructor = 1; # no other constructor, make a Moo one
      }
      ($con ? ref($con) : 'Method::Generate::Constructor')
        ->new(
          package => $target,
          accessor_generator => $class->_accessor_maker_for($target),
          construction_string => (
            $moo_constructor
              ? ($con ? $con->construction_string : undef)
              : ('$class->'.$target.'::SUPER::new($class->can(q[FOREIGNBUILDARGS]) ? $class->FOREIGNBUILDARGS(@_) : @_)')
          ),
          subconstructor_handler => (
            '      if ($Moo::MAKERS{$class}) {'."\n"
            .'        '.$class.'->_constructor_maker_for($class,'.perlstring($target).');'."\n"
            .'        return $class->new(@_)'.";\n"
            .'      } elsif ($INC{"Moose.pm"} and my $meta = Class::MOP::get_metaclass_by_name($class)) {'."\n"
            .'        return $meta->new_object($class->BUILDARGS(@_));'."\n"
            .'      }'."\n"
          ),
        )
        ->install_delayed
        ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
    }
  }
  
  1;
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  Moo - Minimalist Object Orientation (with Moose compatibility)
  
  =head1 SYNOPSIS
  
   package Cat::Food;
  
   use Moo;
  
   sub feed_lion {
     my $self = shift;
     my $amount = shift || 1;
  
     $self->pounds( $self->pounds - $amount );
   }
  
   has taste => (
     is => 'ro',
   );
  
   has brand => (
     is  => 'ro',
     isa => sub {
       die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ'
     },
   );
  
   has pounds => (
     is  => 'rw',
     isa => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 },
   );
  
   1;
  
  And elsewhere:
  
   my $full = Cat::Food->new(
      taste  => 'DELICIOUS.',
      brand  => 'SWEET-TREATZ',
      pounds => 10,
   );
  
   $full->feed_lion;
  
   say $full->pounds;
  
  =head1 DESCRIPTION
  
  This module is an extremely light-weight subset of L<Moose> optimised for
  rapid startup and "pay only for what you use".
  
  It also avoids depending on any XS modules to allow simple deployments.  The
  name C<Moo> is based on the idea that it provides almost -- but not quite -- two
  thirds of L<Moose>.
  
  Unlike L<Mouse> this module does not aim at full compatibility with
  L<Moose>'s surface syntax, preferring instead of provide full interoperability
  via the metaclass inflation capabilities described in L</MOO AND MOOSE>.
  
  For a full list of the minor differences between L<Moose> and L<Moo>'s surface
  syntax, see L</INCOMPATIBILITIES WITH MOOSE>.
  
  =head1 WHY MOO EXISTS
  
  If you want a full object system with a rich Metaprotocol, L<Moose> is
  already wonderful.
  
  However, sometimes you're writing a command line script or a CGI script
  where fast startup is essential, or code designed to be deployed as a single
  file via L<App::FatPacker>, or you're writing a CPAN module and you want it
  to be usable by people with those constraints.
  
  I've tried several times to use L<Mouse> but it's 3x the size of Moo and
  takes longer to load than most of my Moo based CGI scripts take to run.
  
  If you don't want L<Moose>, you don't want "less metaprotocol" like L<Mouse>,
  you want "as little as possible" -- which means "no metaprotocol", which is
  what Moo provides.
  
  Better still, if you install and load L<Moose>, we set up metaclasses for your
  L<Moo> classes and L<Moo::Role> roles, so you can use them in L<Moose> code
  without ever noticing that some of your codebase is using L<Moo>.
  
  Hence, Moo exists as its name -- Minimal Object Orientation -- with a pledge
  to make it smooth to upgrade to L<Moose> when you need more than minimal
  features.
  
  =head1 MOO AND MOOSE
  
  If L<Moo> detects L<Moose> being loaded, it will automatically register
  metaclasses for your L<Moo> and L<Moo::Role> packages, so you should be able
  to use them in L<Moose> code without anybody ever noticing you aren't using
  L<Moose> everywhere.
  
  L<Moo> will also create L<Moose type constraints|Moose::Manual::Types> for
  classes and roles, so that C<< isa => 'MyClass' >> and C<< isa => 'MyRole' >>
  work the same as for L<Moose> classes and roles.
  
  Extending a L<Moose> class or consuming a L<Moose::Role> will also work.
  
  So will extending a L<Mouse> class or consuming a L<Mouse::Role> - but note
  that we don't provide L<Mouse> metaclasses or metaroles so the other way
  around doesn't work. This feature exists for L<Any::Moose> users porting to
  L<Moo>; enabling L<Mouse> users to use L<Moo> classes is not a priority for us.
  
  This means that there is no need for anything like L<Any::Moose> for Moo
  code - Moo and Moose code should simply interoperate without problem. To
  handle L<Mouse> code, you'll likely need an empty Moo role or class consuming
  or extending the L<Mouse> stuff since it doesn't register true L<Moose>
  metaclasses like L<Moo> does.
  
  If you want types to be upgraded to the L<Moose> types, use
  L<MooX::Types::MooseLike> and install the L<MooseX::Types> library to
  match the L<MooX::Types::MooseLike> library you're using - L<Moo> will
  load the L<MooseX::Types> library and use that type for the newly created
  metaclass.
  
  If you need to disable the metaclass creation, add:
  
    no Moo::sification;
  
  to your code before Moose is loaded, but bear in mind that this switch is
  currently global and turns the mechanism off entirely so don't put this
  in library code.
  
  =head1 MOO AND CLASS::XSACCESSOR
  
  If a new enough version of L<Class::XSAccessor> is available, it
  will be used to generate simple accessors, readers, and writers for
  a speed boost.  Simple accessors are those without lazy defaults,
  type checks/coercions, or triggers.  Readers and writers generated
  by L<Class::XSAccessor> will behave slightly differently: they will
  reject attempts to call them with the incorrect number of parameters.
  
  =head1 MOO VERSUS ANY::MOOSE
  
  L<Any::Moose> will load L<Mouse> normally, and L<Moose> in a program using
  L<Moose> - which theoretically allows you to get the startup time of L<Mouse>
  without disadvantaging L<Moose> users.
  
  Sadly, this doesn't entirely work, since the selection is load order dependent
  - L<Moo>'s metaclass inflation system explained above in L</MOO AND MOOSE> is
  significantly more reliable.
  
  So if you want to write a CPAN module that loads fast or has only pure perl
  dependencies but is also fully usable by L<Moose> users, you should be using
  L<Moo>.
  
  For a full explanation, see the article
  L<http://shadow.cat/blog/matt-s-trout/moo-versus-any-moose> which explains
  the differing strategies in more detail and provides a direct example of
  where L<Moo> succeeds and L<Any::Moose> fails.
  
  =head1 IMPORTED METHODS
  
  =head2 new
  
   Foo::Bar->new( attr1 => 3 );
  
  or
  
   Foo::Bar->new({ attr1 => 3 });
  
  =head2 BUILDARGS
  
   sub BUILDARGS {
     my ( $class, @args ) = @_;
  
     unshift @args, "attr1" if @args % 2 == 1;
  
     return { @args };
   };
  
   Foo::Bar->new( 3 );
  
  The default implementation of this method accepts a hash or hash reference of
  named parameters. If it receives a single argument that isn't a hash reference
  it throws an error.
  
  You can override this method in your class to handle other types of options
  passed to the constructor.
  
  This method should always return a hash reference of named options.
  
  =head2 FOREIGNBUILDARGS
  
  If you are inheriting from a non-Moo class, the arguments passed to the parent
  class constructor can be manipulated by defining a C<FOREIGNBUILDARGS> method.
  It will receive the same arguments as C<BUILDARGS>, and should return a list
  of arguments to pass to the parent class constructor.
  
  =head2 BUILD
  
  Define a C<BUILD> method on your class and the constructor will automatically
  call the C<BUILD> method from parent down to child after the object has
  been instantiated.  Typically this is used for object validation or possibly
  logging.
  
  =head2 DEMOLISH
  
  If you have a C<DEMOLISH> method anywhere in your inheritance hierarchy,
  a C<DESTROY> method is created on first object construction which will call
  C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
  method from child upwards to parents.
  
  Note that the C<DESTROY> method is created on first construction of an object
  of your class in order to not add overhead to classes without C<DEMOLISH>
  methods; this may prove slightly surprising if you try and define your own.
  
  =head2 does
  
   if ($foo->does('Some::Role1')) {
     ...
   }
  
  Returns true if the object composes in the passed role.
  
  =head1 IMPORTED SUBROUTINES
  
  =head2 extends
  
   extends 'Parent::Class';
  
  Declares base class. Multiple superclasses can be passed for multiple
  inheritance (but please use roles instead).
  
  Calling extends more than once will REPLACE your superclasses, not add to
  them like 'use base' would.
  
  =head2 with
  
   with 'Some::Role1';
  
  or
  
   with 'Some::Role1', 'Some::Role2';
  
  Composes one or more L<Moo::Role> (or L<Role::Tiny>) roles into the current
  class.  An error will be raised if these roles have conflicting methods.
  
  =head2 has
  
   has attr => (
     is => 'ro',
   );
  
  Declares an attribute for the class.
  
   package Foo;
   use Moo;
   has 'attr' => (
     is => 'ro'
   );
  
   package Bar;
   use Moo;
   extends 'Foo';
   has '+attr' => (
     default => sub { "blah" },
   );
  
  Using the C<+> notation, it's possible to override an attribute.
  
  The options for C<has> are as follows:
  
  =over 2
  
  =item * is
  
  B<required>, may be C<ro>, C<lazy>, C<rwp> or C<rw>.
  
  C<ro> generates an accessor that dies if you attempt to write to it - i.e.
  a getter only - by defaulting C<reader> to the name of the attribute.
  
  C<lazy> generates a reader like C<ro>, but also sets C<lazy> to 1 and
  C<builder> to C<_build_${attribute_name}> to allow on-demand generated
  attributes.  This feature was my attempt to fix my incompetence when
  originally designing C<lazy_build>, and is also implemented by
  L<MooseX::AttributeShortcuts>. There is, however, nothing to stop you
  using C<lazy> and C<builder> yourself with C<rwp> or C<rw> - it's just that
  this isn't generally a good idea so we don't provide a shortcut for it.
  
  C<rwp> generates a reader like C<ro>, but also sets C<writer> to
  C<_set_${attribute_name}> for attributes that are designed to be written
  from inside of the class, but read-only from outside.
  This feature comes from L<MooseX::AttributeShortcuts>.
  
  C<rw> generates a normal getter/setter by defaulting C<accessor> to the
  name of the attribute.
  
  =item * isa
  
  Takes a coderef which is meant to validate the attribute.  Unlike L<Moose>, Moo
  does not include a basic type system, so instead of doing C<< isa => 'Num' >>,
  one should do
  
   isa => sub {
     die "$_[0] is not a number!" unless looks_like_number $_[0]
   },
  
  Note that the return value is ignored, only whether the sub lives or
  dies matters.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  Since L<Moo> does B<not> run the C<isa> check before C<coerce> if a coercion
  subroutine has been supplied, C<isa> checks are not structural to your code
  and can, if desired, be omitted on non-debug builds (although if this results
  in an uncaught bug causing your program to break, the L<Moo> authors guarantee
  nothing except that you get to keep both halves).
  
  If you want L<MooseX::Types> style named types, look at
  L<MooX::Types::MooseLike>.
  
  To cause your C<isa> entries to be automatically mapped to named
  L<Moose::Meta::TypeConstraint> objects (rather than the default behaviour
  of creating an anonymous type), set:
  
    $Moo::HandleMoose::TYPE_MAP{$isa_coderef} = sub {
      require MooseX::Types::Something;
      return MooseX::Types::Something::TypeName();
    };
  
  Note that this example is purely illustrative; anything that returns a
  L<Moose::Meta::TypeConstraint> object or something similar enough to it to
  make L<Moose> happy is fine.
  
  =item * coerce
  
  Takes a coderef which is meant to coerce the attribute.  The basic idea is to
  do something like the following:
  
   coerce => sub {
     $_[0] + 1 unless $_[0] % 2
   },
  
  Note that L<Moo> will always fire your coercion: this is to permit
  C<isa> entries to be used purely for bug trapping, whereas coercions are
  always structural to your code. We do, however, apply any supplied C<isa>
  check after the coercion has run to ensure that it returned a valid value.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * handles
  
  Takes a string
  
    handles => 'RobotRole'
  
  Where C<RobotRole> is a role (L<Moo::Role>) that defines an interface which
  becomes the list of methods to handle.
  
  Takes a list of methods
  
   handles => [ qw( one two ) ]
  
  Takes a hashref
  
   handles => {
     un => 'one',
   }
  
  =item * C<trigger>
  
  Takes a coderef which will get called any time the attribute is set. This
  includes the constructor, but not default or built values. Coderef will be
  invoked against the object with the new value as an argument.
  
  If you set this to just C<1>, it generates a trigger which calls the
  C<_trigger_${attr_name}> method on C<$self>. This feature comes from
  L<MooseX::AttributeShortcuts>.
  
  Note that Moose also passes the old value, if any; this feature is not yet
  supported.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * C<default>
  
  Takes a coderef which will get called with $self as its only argument
  to populate an attribute if no value is supplied to the constructor - or
  if the attribute is lazy, when the attribute is first retrieved if no
  value has yet been provided.
  
  If a simple scalar is provided, it will be inlined as a string. Any non-code
  reference (hash, array) will result in an error - for that case instead use
  a code reference that returns the desired value.
  
  Note that if your default is fired during new() there is no guarantee that
  other attributes have been populated yet so you should not rely on their
  existence.
  
  L<Sub::Quote aware|/SUB QUOTE AWARE>
  
  =item * C<predicate>
  
  Takes a method name which will return true if an attribute has a value.
  
  If you set this to just C<1>, the predicate is automatically named
  C<has_${attr_name}> if your attribute's name does not start with an
  underscore, or C<_has_${attr_name_without_the_underscore}> if it does.
  This feature comes from L<MooseX::AttributeShortcuts>.
  
  =item * C<builder>
  
  Takes a method name which will be called to create the attribute - functions
  exactly like default except that instead of calling
  
    $default->($self);
  
  Moo will call
  
    $self->$builder;
  
  The following features come from L<MooseX::AttributeShortcuts>:
  
  If you set this to just C<1>, the builder is automatically named
  C<_build_${attr_name}>.
  
  If you set this to a coderef or code-convertible object, that variable will be
  installed under C<$class::_build_${attr_name}> and the builder set to the same
  name.
  
  =item * C<clearer>
  
  Takes a method name which will clear the attribute.
  
  If you set this to just C<1>, the clearer is automatically named
  C<clear_${attr_name}> if your attribute's name does not start with an
  underscore, or <_clear_${attr_name_without_the_underscore}> if it does.
  This feature comes from L<MooseX::AttributeShortcuts>.
  
  =item * C<lazy>
  
  B<Boolean>.  Set this if you want values for the attribute to be grabbed
  lazily.  This is usually a good idea if you have a L</builder> which requires
  another attribute to be set.
  
  =item * C<required>
  
  B<Boolean>.  Set this if the attribute must be passed on instantiation.
  
  =item * C<reader>
  
  The value of this attribute will be the name of the method to get the value of
  the attribute.  If you like Java style methods, you might set this to
  C<get_foo>
  
  =item * C<writer>
  
  The value of this attribute will be the name of the method to set the value of
  the attribute.  If you like Java style methods, you might set this to
  C<set_foo>.
  
  =item * C<weak_ref>
  
  B<Boolean>.  Set this if you want the reference that the attribute contains to
  be weakened; use this when circular references are possible, which will cause
  leaks.
  
  =item * C<init_arg>
  
  Takes the name of the key to look for at instantiation time of the object.  A
  common use of this is to make an underscored attribute have a non-underscored
  initialization name. C<undef> means that passing the value in on instantiation
  is ignored.
  
  =item * C<moosify>
  
  Takes either a coderef or array of coderefs which is meant to transform the
  given attributes specifications if necessary when upgrading to a Moose role or
  class. You shouldn't need this by default, but is provided as a means of
  possible extensibility.
  
  =back
  
  =head2 before
  
   before foo => sub { ... };
  
  See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full
  documentation.
  
  =head2 around
  
   around foo => sub { ... };
  
  See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full
  documentation.
  
  =head2 after
  
   after foo => sub { ... };
  
  See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full
  documentation.
  
  =head1 SUB QUOTE AWARE
  
  L<Sub::Quote/quote_sub> allows us to create coderefs that are "inlineable,"
  giving us a handy, XS-free speed boost.  Any option that is L<Sub::Quote>
  aware can take advantage of this.
  
  To do this, you can write
  
    use Moo;
    use Sub::Quote;
  
    has foo => (
      is => 'ro',
      isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 })
    );
  
  which will be inlined as
  
    do {
      local @_ = ($_[0]->{foo});
      die "Not <3" unless $_[0] < 3;
    }
  
  or to avoid localizing @_,
  
    has foo => (
      is => 'ro',
      isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 })
    );
  
  which will be inlined as
  
    do {
      my ($val) = ($_[0]->{foo});
      die "Not <3" unless $val < 3;
    }
  
  See L<Sub::Quote> for more information, including how to pass lexical
  captures that will also be compiled into the subroutine.
  
  =head1 INCOMPATIBILITIES WITH MOOSE
  
  There is no built-in type system.  C<isa> is verified with a coderef; if you
  need complex types, just make a library of coderefs, or better yet, functions
  that return quoted subs. L<MooX::Types::MooseLike> provides a similar API
  to L<MooseX::Types::Moose> so that you can write
  
    has days_to_live => (is => 'ro', isa => Int);
  
  and have it work with both; it is hoped that providing only subrefs as an
  API will encourage the use of other type systems as well, since it's
  probably the weakest part of Moose design-wise.
  
  C<initializer> is not supported in core since the author considers it to be a
  bad idea and Moose best practices recommend avoiding it. Meanwhile C<trigger> or
  C<coerce> are more likely to be able to fulfill your needs.
  
  There is no meta object.  If you need this level of complexity you wanted
  L<Moose> - Moo succeeds at being small because it explicitly does not
  provide a metaprotocol. However, if you load L<Moose>, then
  
    Class::MOP::class_of($moo_class_or_role)
  
  will return an appropriate metaclass pre-populated by L<Moo>.
  
  No support for C<super>, C<override>, C<inner>, or C<augment> - the author
  considers augment to be a bad idea, and override can be translated:
  
    override foo => sub {
      ...
      super();
      ...
    };
  
    around foo => sub {
      my ($orig, $self) = (shift, shift);
      ...
      $self->$orig(@_);
      ...
    };
  
  The C<dump> method is not provided by default. The author suggests loading
  L<Devel::Dwarn> into C<main::> (via C<perl -MDevel::Dwarn ...> for example) and
  using C<$obj-E<gt>$::Dwarn()> instead.
  
  L</default> only supports coderefs and plain scalars, because passing a hash
  or array reference as a default is almost always incorrect since the value is
  then shared between all objects using that default.
  
  C<lazy_build> is not supported; you are instead encouraged to use the
  C<< is => 'lazy' >> option supported by L<Moo> and L<MooseX::AttributeShortcuts>.
  
  C<auto_deref> is not supported since the author considers it a bad idea and
  it has been considered best practice to avoid it for some time.
  
  C<documentation> will show up in a L<Moose> metaclass created from your class
  but is otherwise ignored. Then again, L<Moose> ignores it as well, so this
  is arguably not an incompatibility.
  
  Since C<coerce> does not require C<isa> to be defined but L<Moose> does
  require it, the metaclass inflation for coerce alone is a trifle insane
  and if you attempt to subtype the result will almost certainly break.
  
  Handling of warnings: when you C<use Moo> we enable FATAL warnings.  The nearest
  similar invocation for L<Moose> would be:
  
    use Moose;
    use warnings FATAL => "all";
  
  Additionally, L<Moo> supports a set of attribute option shortcuts intended to
  reduce common boilerplate.  The set of shortcuts is the same as in the L<Moose>
  module L<MooseX::AttributeShortcuts> as of its version 0.009+.  So if you:
  
      package MyClass;
      use Moo;
  
  The nearest L<Moose> invocation would be:
  
      package MyClass;
  
      use Moose;
      use warnings FATAL => "all";
      use MooseX::AttributeShortcuts;
  
  or, if you're inheriting from a non-Moose class,
  
      package MyClass;
  
      use Moose;
      use MooseX::NonMoose;
      use warnings FATAL => "all";
      use MooseX::AttributeShortcuts;
  
  Finally, Moose requires you to call
  
      __PACKAGE__->meta->make_immutable;
  
  at the end of your class to get an inlined (i.e. not horribly slow)
  constructor. Moo does it automatically the first time ->new is called
  on your class. (C<make_immutable> is a no-op in Moo to ease migration.)
  
  An extension L<MooX::late> exists to ease translating Moose packages
  to Moo by providing a more Moose-like interface.
  
  =head1 SUPPORT
  
  Users' IRC: #moose on irc.perl.org
  
  =for html <a href="http://chat.mibbit.com/#moose@irc.perl.org">(click for instant chatroom login)</a>
  
  Development and contribution IRC: #web-simple on irc.perl.org
  
  =for html <a href="http://chat.mibbit.com/#web-simple@irc.perl.org">(click for instant chatroom login)</a>
  
  Bugtracker: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Moo>
  
  Git repository: L<git://git.shadowcat.co.uk/gitmo/Moo.git>
  
  Git web access: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo/Moo.git>
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
  
  frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
  
  hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org>
  
  jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com>
  
  ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
  
  chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
  
  ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org>
  
  doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net>
  
  perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org>
  
  Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
  
  ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
  
  tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
  
  haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
  
  mattp - Matt Phillips (cpan:MATTP) <mattp@cpan.org>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010-2011 the Moo L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself. See L<http://dev.perl.org/licenses/>.
  
  =cut
MOO

$fatpacked{"Moo/Conflicts.pm"} = <<'MOO_CONFLICTS';
  package # hide from PAUSE
      Moo::Conflicts;
  
  use strict;
  use warnings;
  
  use Dist::CheckConflicts
      -dist      => 'Moo',
      -conflicts => {
          # enter conflicting downstream deps here, with the version indicating
          # the last *broken* version that *does not work*.
          'HTML::Restrict' => '2.1.5',
      },
  
      # these dists' ::Conflicts modules (if they exist) are also checked for
      # more incompatibilities -- should include all runtime prereqs here.
      -also => [ qw(
          Carp
          Class::Method::Modifiers
          strictures
          Module::Runtime
          Role::Tiny
          Devel::GlobalDestruction
      ) ],
  ;
  
  1;
MOO_CONFLICTS

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

$fatpacked{"Moo/HandleMoose/FakeMetaClass.pm"} = <<'MOO_HANDLEMOOSE_FAKEMETACLASS';
  package Moo::HandleMoose::FakeMetaClass;
  
  sub DESTROY { }
  
  sub AUTOLOAD {
    my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/);
    require Moo::HandleMoose;
    Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->$meth(@_)
  }
  sub can {
    require Moo::HandleMoose;
    Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->can(@_)
  }
  sub isa {
    require Moo::HandleMoose;
    Moo::HandleMoose::inject_real_metaclass_for((shift)->{name})->isa(@_)
  }
  sub make_immutable { $_[0] }
  
  1;
MOO_HANDLEMOOSE_FAKEMETACLASS

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

$fatpacked{"Moo/Role.pm"} = <<'MOO_ROLE';
  package Moo::Role;
  
  use strictures 1;
  use Moo::_Utils;
  use Role::Tiny ();
  use base qw(Role::Tiny);
  
  require Moo::sification;
  
  BEGIN { *INFO = \%Role::Tiny::INFO }
  
  our %INFO;
  our %APPLY_DEFAULTS;
  
  sub _install_tracked {
    my ($target, $name, $code) = @_;
    $INFO{$target}{exports}{$name} = $code;
    _install_coderef "${target}::${name}" => "Moo::Role::${name}" => $code;
  }
  
  sub import {
    my $target = caller;
    my ($me) = @_;
    strictures->import;
    if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) {
      die "Cannot import Moo::Role into a Moo class";
    }
    $INFO{$target} ||= {};
    # get symbol table reference
    my $stash = do { no strict 'refs'; \%{"${target}::"} };
    _install_tracked $target => has => sub {
      my ($name_proto, %spec) = @_;
      my $name_isref = ref $name_proto eq 'ARRAY';
      foreach my $name ($name_isref ? @$name_proto : $name_proto) {
        my $spec_ref = $name_isref ? +{%spec} : \%spec;
        ($INFO{$target}{accessor_maker} ||= do {
          require Method::Generate::Accessor;
          Method::Generate::Accessor->new
        })->generate_method($target, $name, $spec_ref);
        push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref;
        $me->_maybe_reset_handlemoose($target);
      }
    };
    # install before/after/around subs
    foreach my $type (qw(before after around)) {
      _install_tracked $target => $type => sub {
        require Class::Method::Modifiers;
        push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
        $me->_maybe_reset_handlemoose($target);
      };
    }
    _install_tracked $target => requires => sub {
      push @{$INFO{$target}{requires}||=[]}, @_;
      $me->_maybe_reset_handlemoose($target);
    };
    _install_tracked $target => with => sub {
      $me->apply_roles_to_package($target, @_);
      $me->_maybe_reset_handlemoose($target);
    };
    return if $INFO{$target}{is_role}; # already exported into this package
    $INFO{$target}{is_role} = 1;
    *{_getglob("${target}::meta")} = $me->can('meta');
    # grab all *non-constant* (stash slot is not a scalarref) subs present
    # in the symbol table and store their refaddrs (no need to forcibly
    # inflate constant subs into real subs) - also add '' to here (this
    # is used later) with a map to the coderefs in case of copying or re-use
    my @not_methods = ('', map { *$_{CODE}||() } grep !ref($_), values %$stash);
    @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods;
    # a role does itself
    $Role::Tiny::APPLIED_TO{$target} = { $target => undef };
  
    if ($INC{'Moo/HandleMoose.pm'}) {
      Moo::HandleMoose::inject_fake_metaclass_for($target);
    }
  }
  
  # duplicate from Moo::Object
  sub meta {
    require Moo::HandleMoose::FakeMetaClass;
    my $class = ref($_[0])||$_[0];
    bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
  }
  
  sub unimport {
    my $target = caller;
    _unimport_coderefs($target, $INFO{$target});
  }
  
  sub _maybe_reset_handlemoose {
    my ($class, $target) = @_;
    if ($INC{"Moo/HandleMoose.pm"}) {
      Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
    }
  }
  
  sub _inhale_if_moose {
    my ($self, $role) = @_;
    _load_module($role);
    my $meta;
    if (!$INFO{$role}
        and (
          $INC{"Moose.pm"}
          and $meta = Class::MOP::class_of($role)
          and $meta->isa('Moose::Meta::Role')
        )
        or (
          Mouse::Util->can('find_meta')
          and $meta = Mouse::Util::find_meta($role)
          and $meta->isa('Mouse::Meta::Role')
       )
    ) {
      $INFO{$role}{methods} = {
        map +($_ => $role->can($_)),
          grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
            $meta->get_method_list
      };
      $Role::Tiny::APPLIED_TO{$role} = {
        map +($_->name => 1), $meta->calculate_all_roles
      };
      $INFO{$role}{requires} = [ $meta->get_required_method_list ];
      $INFO{$role}{attributes} = [
        map +($_ => do {
          my $attr = $meta->get_attribute($_);
          my $is_mouse = $meta->isa('Mouse::Meta::Role');
          my $spec = { %{ $is_mouse ? $attr : $attr->original_options } };
  
          if ($spec->{isa}) {
  
            my $get_constraint = do {
              my $pkg = $is_mouse
                          ? 'Mouse::Util::TypeConstraints'
                          : 'Moose::Util::TypeConstraints';
              _load_module($pkg);
              $pkg->can('find_or_create_isa_type_constraint');
            };
  
            my $tc = $get_constraint->($spec->{isa});
            my $check = $tc->_compiled_type_constraint;
  
            $spec->{isa} = sub {
              &$check or die "Type constraint failed for $_[0]"
            };
  
            if ($spec->{coerce}) {
  
               # Mouse has _compiled_type_coercion straight on the TC object
               $spec->{coerce} = $tc->${\(
                 $tc->can('coercion')||sub { $_[0] }
               )}->_compiled_type_coercion;
            }
          }
          $spec;
        }), $meta->get_attribute_list
      ];
      my $mods = $INFO{$role}{modifiers} = [];
      foreach my $type (qw(before after around)) {
        # Mouse pokes its own internals so we have to fall back to doing
        # the same thing in the absence of the Moose API method
        my $map = $meta->${\(
          $meta->can("get_${type}_method_modifiers_map")
          or sub { shift->{"${type}_method_modifiers"} }
        )};
        foreach my $method (keys %$map) {
          foreach my $mod (@{$map->{$method}}) {
            push @$mods, [ $type => $method => $mod ];
          }
        }
      }
      require Class::Method::Modifiers if @$mods;
      $INFO{$role}{inhaled_from_moose} = 1;
      $INFO{$role}{is_role} = 1;
    }
  }
  
  sub _maybe_make_accessors {
    my ($self, $target, $role) = @_;
    my $m;
    if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}
        or $INC{"Moo.pm"}
        and $m = Moo->_accessor_maker_for($target)
        and ref($m) ne 'Method::Generate::Accessor') {
      $self->_make_accessors($target, $role);
    }
  }
  
  sub _make_accessors_if_moose {
    my ($self, $target, $role) = @_;
    if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}) {
      $self->_make_accessors($target, $role);
    }
  }
  
  sub _make_accessors {
    my ($self, $target, $role) = @_;
    my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do {
      require Method::Generate::Accessor;
      Method::Generate::Accessor->new
    });
    my $con_gen = $Moo::MAKERS{$target}{constructor};
    my @attrs = @{$INFO{$role}{attributes}||[]};
    while (my ($name, $spec) = splice @attrs, 0, 2) {
      # needed to ensure we got an index for an arrayref based generator
      if ($con_gen) {
        $spec = $con_gen->all_attribute_specs->{$name};
      }
      $acc_gen->generate_method($target, $name, $spec);
    }
  }
  
  sub role_application_steps {
    qw(_handle_constructor _maybe_make_accessors),
      $_[0]->SUPER::role_application_steps;
  }
  
  sub apply_roles_to_package {
    my ($me, $to, @roles) = @_;
    foreach my $role (@roles) {
      $me->_inhale_if_moose($role);
      die "${role} is not a Moo::Role" unless $INFO{$role};
    }
    $me->SUPER::apply_roles_to_package($to, @roles);
  }
  
  sub apply_single_role_to_package {
    my ($me, $to, $role) = @_;
    $me->_inhale_if_moose($role);
    die "${role} is not a Moo::Role" unless $INFO{$role};
    $me->SUPER::apply_single_role_to_package($to, $role);
  }
  
  sub create_class_with_roles {
    my ($me, $superclass, @roles) = @_;
  
    my $new_name = join(
      '__WITH__', $superclass, my $compose_name = join '__AND__', @roles
    );
  
    return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
  
    foreach my $role (@roles) {
        $me->_inhale_if_moose($role);
    }
  
    my $m;
    if ($INC{"Moo.pm"}
        and $m = Moo->_accessor_maker_for($superclass)
        and ref($m) ne 'Method::Generate::Accessor') {
      # old fashioned way time.
      *{_getglob("${new_name}::ISA")} = [ $superclass ];
      $me->apply_roles_to_package($new_name, @roles);
      return $new_name;
    }
  
    require Sub::Quote;
  
    $me->SUPER::create_class_with_roles($superclass, @roles);
  
    foreach my $role (@roles) {
      die "${role} is not a Role::Tiny" unless $INFO{$role};
    }
  
    $Moo::MAKERS{$new_name} = {is_class => 1};
  
    $me->_handle_constructor($new_name, $_) for @roles;
  
    return $new_name;
  }
  
  sub apply_roles_to_object {
    my ($me, $object, @roles) = @_;
    my $new = $me->SUPER::apply_roles_to_object($object, @roles);
  
    my $apply_defaults = $APPLY_DEFAULTS{ref $new} ||= do {
      my %attrs = map { @{$INFO{$_}{attributes}||[]} } @roles;
  
      if ($INC{'Moo.pm'}
          and keys %attrs
          and my $con_gen = Moo->_constructor_maker_for(ref $new)
          and my $m = Moo->_accessor_maker_for(ref $new)) {
        require Sub::Quote;
  
        my $specs = $con_gen->all_attribute_specs;
  
        my $assign = '';
        my %captures;
        foreach my $name ( keys %attrs ) {
          my $spec = $specs->{$name};
          if ($m->has_eager_default($name, $spec)) {
            my ($has, $has_cap)
              = $m->generate_simple_has('$_[0]', $name, $spec);
            my ($code, $pop_cap)
              = $m->generate_use_default('$_[0]', $name, $spec, $has);
  
            $assign .= $code;
            @captures{keys %$has_cap, keys %$pop_cap}
              = (values %$has_cap, values %$pop_cap);
          }
        }
        Sub::Quote::quote_sub($assign, \%captures);
      }
      else {
        sub {};
      }
    };
    $new->$apply_defaults;
    return $new;
  }
  
  sub _composable_package_for {
    my ($self, $role) = @_;
    my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
    return $composed_name if $Role::Tiny::COMPOSED{role}{$composed_name};
    $self->_make_accessors_if_moose($composed_name, $role);
    $self->SUPER::_composable_package_for($role);
  }
  
  sub _install_single_modifier {
    my ($me, @args) = @_;
    _install_modifier(@args);
  }
  
  sub _handle_constructor {
    my ($me, $to, $role) = @_;
    my $attr_info = $INFO{$role} && $INFO{$role}{attributes};
    return unless $attr_info && @$attr_info;
    if ($INFO{$to}) {
      push @{$INFO{$to}{attributes}||=[]}, @$attr_info;
    } else {
      # only fiddle with the constructor if the target is a Moo class
      if ($INC{"Moo.pm"}
          and my $con = Moo->_constructor_maker_for($to)) {
        # shallow copy of the specs since the constructor will assign an index
        $con->register_attribute_specs(map ref() ? { %$_ } : $_, @$attr_info);
      }
    }
  }
  
  1;
  
  =head1 NAME
  
  Moo::Role - Minimal Object Orientation support for Roles
  
  =head1 SYNOPSIS
  
   package My::Role;
  
   use Moo::Role;
  
   sub foo { ... }
  
   sub bar { ... }
  
   has baz => (
     is => 'ro',
   );
  
   1;
  
  And elsewhere:
  
   package Some::Class;
  
   use Moo;
  
   # bar gets imported, but not foo
   with('My::Role');
  
   sub foo { ... }
  
   1;
  
  =head1 DESCRIPTION
  
  C<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
  documentation on how this works.  The main addition here is extra bits to make
  the roles more "Moosey;" which is to say, it adds L</has>.
  
  =head1 IMPORTED SUBROUTINES
  
  See L<Role::Tiny/IMPORTED SUBROUTINES> for all the other subroutines that are
  imported by this module.
  
  =head2 has
  
   has attr => (
     is => 'ro',
   );
  
  Declares an attribute for the class to be composed into.  See
  L<Moo/has> for all options.
  
  =head1 SUPPORT
  
  See L<Moo> for support and contact information.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
MOO_ROLE

$fatpacked{"Moo/_Utils.pm"} = <<'MOO__UTILS';
  package Moo::_Utils;
  
  no warnings 'once'; # guard against -w
  
  sub _getglob { \*{$_[0]} }
  sub _getstash { \%{"$_[0]::"} }
  
  use constant lt_5_8_3 => ( $] < 5.008003 or $ENV{MOO_TEST_PRE_583} ) ? 1 : 0;
  use constant can_haz_subname => eval { require Sub::Name };
  
  use strictures 1;
  use Module::Runtime qw(require_module);
  use Devel::GlobalDestruction ();
  use base qw(Exporter);
  use Moo::_mro;
  
  our @EXPORT = qw(
      _getglob _install_modifier _load_module _maybe_load_module
      _get_linear_isa _getstash _install_coderef _name_coderef
      _unimport_coderefs _in_global_destruction
  );
  
  sub _in_global_destruction ();
  *_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction;
  
  sub _install_modifier {
    my ($into, $type, $name, $code) = @_;
  
    if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
      require Sub::Defer;
      Sub::Defer::undefer_sub($to_modify);
    }
  
    Class::Method::Modifiers::install_modifier(@_);
  }
  
  our %MAYBE_LOADED;
  
  sub _load_module {
    (my $proto = $_[0]) =~ s/::/\//g;
    return 1 if $INC{"${proto}.pm"};
    # can't just ->can('can') because a sub-package Foo::Bar::Baz
    # creates a 'Baz::' key in Foo::Bar's symbol table
    my $stash = _getstash($_[0])||{};
    return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
    require_module($_[0]);
    return 1;
  }
  
  sub _maybe_load_module {
    return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
    (my $proto = $_[0]) =~ s/::/\//g;
    local $@;
    if (eval { require "${proto}.pm"; 1 }) {
      $MAYBE_LOADED{$_[0]} = 1;
    } else {
      if (exists $INC{"${proto}.pm"}) {
        warn "$_[0] exists but failed to load with error: $@";
      }
      $MAYBE_LOADED{$_[0]} = 0;
    }
    return $MAYBE_LOADED{$_[0]};
  }
  
  sub _get_linear_isa {
    return mro::get_linear_isa($_[0]);
  }
  
  sub _install_coderef {
    no warnings 'redefine';
    *{_getglob($_[0])} = _name_coderef(@_);
  }
  
  sub _name_coderef {
    shift if @_ > 2; # three args is (target, name, sub)
    can_haz_subname ? Sub::Name::subname(@_) : $_[1];
  }
  
  sub _unimport_coderefs {
    my ($target, $info) = @_;
    return unless $info and my $exports = $info->{exports};
    my %rev = reverse %$exports;
    my $stash = _getstash($target);
    foreach my $name (keys %$exports) {
      if ($stash->{$name} and defined(&{$stash->{$name}})) {
        if ($rev{$target->can($name)}) {
          my $old = delete $stash->{$name};
          my $full_name = join('::',$target,$name);
          # Copy everything except the code slot back into place (e.g. $has)
          foreach my $type (qw(SCALAR HASH ARRAY IO)) {
            next unless defined(*{$old}{$type});
            no strict 'refs';
            *$full_name = *{$old}{$type};
          }
        }
      }
    }
  }
  
  sub STANDARD_DESTROY {
    my $self = shift;
  
    my $e = do {
      local $?;
      local $@;
      eval {
        $self->DEMOLISHALL(_in_global_destruction);
      };
      $@;
    };
  
    no warnings 'misc';
    die $e if $e; # rethrow
  }
  
  1;
MOO__UTILS

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

$fatpacked{"Moo/sification.pm"} = <<'MOO_SIFICATION';
  package Moo::sification;
  
  use strictures 1;
  use Moo::_Utils ();
  
  sub unimport { our $disarmed = 1 }
  
  sub Moo::HandleMoose::AuthorityHack::DESTROY {
    unless (our $disarmed or Moo::_Utils::_in_global_destruction) {
      require Moo::HandleMoose;
      Moo::HandleMoose->import;
    }
  }
  
  if ($INC{"Moose.pm"}) {
    require Moo::HandleMoose;
    Moo::HandleMoose->import;
  } else {
    $Moose::AUTHORITY = bless({}, 'Moo::HandleMoose::AuthorityHack');
  }
  
  1;
MOO_SIFICATION

$fatpacked{"Package/Stash.pm"} = <<'PACKAGE_STASH';
  package Package::Stash;
  BEGIN {
    $Package::Stash::AUTHORITY = 'cpan:DOY';
  }
  {
    $Package::Stash::VERSION = '0.35';
  }
  use strict;
  use warnings;
  use 5.008001;
  # ABSTRACT: routines for manipulating stashes
  
  our $IMPLEMENTATION;
  
  use Module::Implementation 0.06;
  
  BEGIN {
      local $ENV{PACKAGE_STASH_IMPLEMENTATION} = $IMPLEMENTATION
        if ( $IMPLEMENTATION and not $ENV{PACKAGE_STASH_IMPLEMENTATION} );
  
      Module::Implementation::build_loader_sub(
          implementations => [ 'XS', 'PP' ]
      )->();
      $IMPLEMENTATION = Module::Implementation::implementation_for(__PACKAGE__);
  
      my $impl = "Package::Stash::$IMPLEMENTATION";
      my $from = $impl->new($impl);
      my $to = $impl->new(__PACKAGE__);
      my $methods = $from->get_all_symbols('CODE');
      for my $meth (keys %$methods) {
          $to->add_symbol("&$meth" => $methods->{$meth});
      }
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Package::Stash - routines for manipulating stashes
  
  =head1 VERSION
  
  version 0.35
  
  =head1 SYNOPSIS
  
    my $stash = Package::Stash->new('Foo');
    $stash->add_symbol('%foo', {bar => 1});
    # $Foo::foo{bar} == 1
    $stash->has_symbol('$foo') # false
    my $namespace = $stash->namespace;
    *{ $namespace->{foo} }{HASH} # {bar => 1}
  
  =head1 DESCRIPTION
  
  Manipulating stashes (Perl's symbol tables) is occasionally necessary, but
  incredibly messy, and easy to get wrong. This module hides all of that behind a
  simple API.
  
  NOTE: Most methods in this class require a variable specification that includes
  a sigil. If this sigil is absent, it is assumed to represent the IO slot.
  
  Due to limitations in the typeglob API available to perl code, and to typeglob
  manipulation in perl being quite slow, this module provides two
  implementations - one in pure perl, and one using XS. The XS implementation is
  to be preferred for most usages; the pure perl one is provided for cases where
  XS modules are not a possibility. The current implementation in use can be set
  by setting C<$ENV{PACKAGE_STASH_IMPLEMENTATION}> or
  C<$Package::Stash::IMPLEMENTATION> before loading Package::Stash (with the
  environment variable taking precedence), otherwise, it will use the XS
  implementation if possible, falling back to the pure perl one.
  
  =head1 METHODS
  
  =head2 new $package_name
  
  Creates a new C<Package::Stash> object, for the package given as the only
  argument.
  
  =head2 name
  
  Returns the name of the package that this object represents.
  
  =head2 namespace
  
  Returns the raw stash itself.
  
  =head2 add_symbol $variable $value %opts
  
  Adds a new package symbol, for the symbol given as C<$variable>, and optionally
  gives it an initial value of C<$value>. C<$variable> should be the name of
  variable including the sigil, so
  
    Package::Stash->new('Foo')->add_symbol('%foo')
  
  will create C<%Foo::foo>.
  
  Valid options (all optional) are C<filename>, C<first_line_num>, and
  C<last_line_num>.
  
  C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
  be used to indicate where the symbol should be regarded as having been defined.
  Currently these values are only used if the symbol is a subroutine ('C<&>'
  sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
  hash is updated to record the values of C<filename>, C<first_line_num>, and
  C<last_line_num> for the subroutine. If these are not passed, their values are
  inferred (as much as possible) from C<caller> information.
  
  This is especially useful for debuggers and profilers, which use C<%DB::sub> to
  determine where the source code for a subroutine can be found.  See
  L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
  information about C<%DB::sub>.
  
  =head2 remove_glob $name
  
  Removes all package variables with the given name, regardless of sigil.
  
  =head2 has_symbol $variable
  
  Returns whether or not the given package variable (including sigil) exists.
  
  =head2 get_symbol $variable
  
  Returns the value of the given package variable (including sigil).
  
  =head2 get_or_add_symbol $variable
  
  Like C<get_symbol>, except that it will return an empty hashref or
  arrayref if the variable doesn't exist.
  
  =head2 remove_symbol $variable
  
  Removes the package variable described by C<$variable> (which includes the
  sigil); other variables with the same name but different sigils will be
  untouched.
  
  =head2 list_all_symbols $type_filter
  
  Returns a list of package variable names in the package, without sigils. If a
  C<type_filter> is passed, it is used to select package variables of a given
  type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
  etc). Note that if the package contained any C<BEGIN> blocks, perl will leave
  an empty typeglob in the C<BEGIN> slot, so this will show up if no filter is
  used (and similarly for C<INIT>, C<END>, etc).
  
  =head2 get_all_symbols $type_filter
  
  Returns a hashref, keyed by the variable names in the package. If
  C<$type_filter> is passed, the hash will contain every variable of that type in
  the package as values, otherwise, it will contain the typeglobs corresponding
  to the variable names (basically, a clone of the stash).
  
  =head1 BUGS / CAVEATS
  
  =over 4
  
  =item * Prior to perl 5.10, scalar slots are only considered to exist if they are defined
  
  This is due to a shortcoming within perl itself. See
  L<perlref/Making References> point 7 for more information.
  
  =item * GLOB and FORMAT variables are not (yet) accessible through this module.
  
  =item * Also, see the BUGS section for the specific backends (L<Package::Stash::XS> and L<Package::Stash::PP>)
  
  =back
  
  Please report any bugs through RT: email
  C<bug-package-stash at rt.cpan.org>, or browse to
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Class::MOP::Package>
  
  This module is a factoring out of code that used to live here
  
  =back
  
  =head1 SUPPORT
  
  You can find this documentation for this module with the perldoc command.
  
      perldoc Package::Stash
  
  You can also look for information at:
  
  =over 4
  
  =item * AnnoCPAN: Annotated CPAN documentation
  
  L<http://annocpan.org/dist/Package-Stash>
  
  =item * CPAN Ratings
  
  L<http://cpanratings.perl.org/d/Package-Stash>
  
  =item * RT: CPAN's request tracker
  
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
  
  =item * Search CPAN
  
  L<http://search.cpan.org/dist/Package-Stash>
  
  =back
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy at tozt dot net>
  
  Based on code from L<Class::MOP::Package>, by Stevan Little and the Moose
  Cabal.
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy@tozt.net>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Jesse Luehrs.
  
  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
PACKAGE_STASH

$fatpacked{"Package/Stash/Conflicts.pm"} = <<'PACKAGE_STASH_CONFLICTS';
  package # hide from PAUSE
      Package::Stash::Conflicts;
  
  use strict;
  use warnings;
  
  use Dist::CheckConflicts
      -dist      => 'Package::Stash',
      -conflicts => {
          'Class::MOP' => '1.08',
          'MooseX::Method::Signatures' => '0.36',
          'MooseX::Role::WithOverloading' => '0.08',
          'namespace::clean' => '0.18',
      },
  
  ;
  
  1;
  
  # ABSTRACT: Provide information on conflicts for Package::Stash
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Package::Stash::Conflicts - Provide information on conflicts for Package::Stash
  
  =head1 VERSION
  
  version 0.35
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy@tozt.net>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Jesse Luehrs.
  
  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
PACKAGE_STASH_CONFLICTS

$fatpacked{"Package/Stash/PP.pm"} = <<'PACKAGE_STASH_PP';
  package Package::Stash::PP;
  BEGIN {
    $Package::Stash::PP::AUTHORITY = 'cpan:DOY';
  }
  {
    $Package::Stash::PP::VERSION = '0.35';
  }
  use strict;
  use warnings;
  # ABSTRACT: pure perl implementation of the Package::Stash API
  
  use B;
  use Carp qw(confess);
  use Scalar::Util qw(blessed reftype weaken);
  use Symbol;
  # before 5.12, assigning to the ISA glob would make it lose its magical ->isa
  # powers
  use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
  # before 5.10, stashes don't ever seem to drop to a refcount of zero, so
  # weakening them isn't helpful
  use constant BROKEN_WEAK_STASH     => ($] < 5.010);
  # before 5.10, the scalar slot was always treated as existing if the
  # glob existed
  use constant BROKEN_SCALAR_INITIALIZATION => ($] < 5.010);
  # add_method on anon stashes triggers rt.perl #1804 otherwise
  # fixed in perl commit v5.13.3-70-g0fe688f
  use constant BROKEN_GLOB_ASSIGNMENT => ($] < 5.013004);
  # pre-5.10, ->isa lookups were cached in the ::ISA::CACHE:: slot
  use constant HAS_ISA_CACHE => ($] < 5.010);
  
  
  sub new {
      my $class = shift;
      my ($package) = @_;
  
      if (!defined($package) || (ref($package) && reftype($package) ne 'HASH')) {
          confess "Package::Stash->new must be passed the name of the "
                . "package to access";
      }
      elsif (ref($package) && reftype($package) eq 'HASH') {
          confess "The PP implementation of Package::Stash does not support "
                . "anonymous stashes before perl 5.14"
              if BROKEN_GLOB_ASSIGNMENT;
  
          return bless {
              'namespace' => $package,
          }, $class;
      }
      elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) {
          return bless {
              'package' => $package,
          }, $class;
      }
      else {
          confess "$package is not a module name";
      }
  
  }
  
  sub name {
      confess "Can't call name as a class method"
          unless blessed($_[0]);
      confess "Can't get the name of an anonymous package"
          unless defined($_[0]->{package});
      return $_[0]->{package};
  }
  
  sub namespace {
      confess "Can't call namespace as a class method"
          unless blessed($_[0]);
  
      if (BROKEN_WEAK_STASH) {
          no strict 'refs';
          return \%{$_[0]->name . '::'};
      }
      else {
          return $_[0]->{namespace} if defined $_[0]->{namespace};
  
          {
              no strict 'refs';
              $_[0]->{namespace} = \%{$_[0]->name . '::'};
          }
  
          weaken($_[0]->{namespace});
  
          return $_[0]->{namespace};
      }
  }
  
  sub _is_anon {
      return !defined $_[0]->{package};
  }
  
  {
      my %SIGIL_MAP = (
          '$' => 'SCALAR',
          '@' => 'ARRAY',
          '%' => 'HASH',
          '&' => 'CODE',
          ''  => 'IO',
      );
  
      sub _deconstruct_variable_name {
          my ($self, $variable) = @_;
  
          my @ret;
          if (ref($variable) eq 'HASH') {
              @ret = @{$variable}{qw[name sigil type]};
          }
          else {
              (defined $variable && length $variable)
                  || confess "You must pass a variable name";
  
              my $sigil = substr($variable, 0, 1, '');
  
              if (exists $SIGIL_MAP{$sigil}) {
                  @ret = ($variable, $sigil, $SIGIL_MAP{$sigil});
              }
              else {
                  @ret = ("${sigil}${variable}", '', $SIGIL_MAP{''});
              }
          }
  
          # XXX in pure perl, this will access things in inner packages,
          # in xs, this will segfault - probably look more into this at
          # some point
          ($ret[0] !~ /::/)
              || confess "Variable names may not contain ::";
  
          return @ret;
      }
  }
  
  sub _valid_for_type {
      my $self = shift;
      my ($value, $type) = @_;
      if ($type eq 'HASH' || $type eq 'ARRAY'
       || $type eq 'IO'   || $type eq 'CODE') {
          return reftype($value) eq $type;
      }
      else {
          my $ref = reftype($value);
          return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING';
      }
  }
  
  sub add_symbol {
      my ($self, $variable, $initial_value, %opts) = @_;
  
      my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  
      if (@_ > 2) {
          $self->_valid_for_type($initial_value, $type)
              || confess "$initial_value is not of type $type";
  
          # cheap fail-fast check for PERLDBf_SUBLINE and '&'
          if ($^P and $^P & 0x10 && $sigil eq '&') {
              my $filename = $opts{filename};
              my $first_line_num = $opts{first_line_num};
  
              (undef, $filename, $first_line_num) = caller
                  if not defined $filename;
  
              my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
  
              # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
              $DB::sub{$self->name . '::' . $name} = "$filename:$first_line_num-$last_line_num";
          }
      }
  
      if (BROKEN_GLOB_ASSIGNMENT) {
          if (@_ > 2) {
              no strict 'refs';
              no warnings 'redefine';
              *{ $self->name . '::' . $name } = ref $initial_value
                  ? $initial_value : \$initial_value;
          }
          else {
              no strict 'refs';
              if (BROKEN_ISA_ASSIGNMENT && $name eq 'ISA') {
                  *{ $self->name . '::' . $name };
              }
              else {
                  my $undef = $self->_undef_ref_for_type($type);
                  *{ $self->name . '::' . $name } = $undef;
              }
          }
      }
      else {
          my $namespace = $self->namespace;
          {
              # using glob aliasing instead of Symbol::gensym, because otherwise,
              # magic doesn't get applied properly.
              # see <20120710063744.19360.qmail@lists-nntp.develooper.com> on p5p
              local *__ANON__:: = $namespace;
              no strict 'refs';
              no warnings 'void';
              *{"__ANON__::$name"};
          }
  
          if (@_ > 2) {
              no warnings 'redefine';
              *{ $namespace->{$name} } = ref $initial_value
                  ? $initial_value : \$initial_value;
          }
          else {
              return if BROKEN_ISA_ASSIGNMENT && $name eq 'ISA';
              *{ $namespace->{$name} } = $self->_undef_ref_for_type($type);
          }
      }
  }
  
  sub _undef_ref_for_type {
      my $self = shift;
      my ($type) = @_;
  
      if ($type eq 'ARRAY') {
          return [];
      }
      elsif ($type eq 'HASH') {
          return {};
      }
      elsif ($type eq 'SCALAR') {
          return \undef;
      }
      elsif ($type eq 'IO') {
          return Symbol::geniosym;
      }
      elsif ($type eq 'CODE') {
          confess "Don't know how to vivify CODE variables";
      }
      else {
          confess "Unknown type $type in vivication";
      }
  }
  
  sub remove_glob {
      my ($self, $name) = @_;
      delete $self->namespace->{$name};
  }
  
  sub has_symbol {
      my ($self, $variable) = @_;
  
      my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  
      my $namespace = $self->namespace;
  
      return unless exists $namespace->{$name};
  
      my $entry_ref = \$namespace->{$name};
      if (reftype($entry_ref) eq 'GLOB') {
          if ($type eq 'SCALAR') {
              if (BROKEN_SCALAR_INITIALIZATION) {
                  return defined ${ *{$entry_ref}{$type} };
              }
              else {
                  my $sv = B::svref_2object($entry_ref)->SV;
                  return $sv->isa('B::SV')
                      || ($sv->isa('B::SPECIAL')
                       && $B::specialsv_name[$$sv] ne 'Nullsv');
              }
          }
          else {
              return defined *{$entry_ref}{$type};
          }
      }
      else {
          # a symbol table entry can be -1 (stub), string (stub with prototype),
          # or reference (constant)
          return $type eq 'CODE';
      }
  }
  
  sub get_symbol {
      my ($self, $variable, %opts) = @_;
  
      my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  
      my $namespace = $self->namespace;
  
      if (!exists $namespace->{$name}) {
          if ($opts{vivify}) {
              $self->add_symbol($variable);
          }
          else {
              return undef;
          }
      }
  
      my $entry_ref = \$namespace->{$name};
  
      if (ref($entry_ref) eq 'GLOB') {
          return *{$entry_ref}{$type};
      }
      else {
          if ($type eq 'CODE') {
              if (BROKEN_GLOB_ASSIGNMENT || !$self->_is_anon) {
                  no strict 'refs';
                  return \&{ $self->name . '::' . $name };
              }
  
              # XXX we should really be able to support arbitrary anonymous
              # stashes here... (not just via Package::Anon)
              if (blessed($namespace) && $namespace->isa('Package::Anon')) {
                  # ->can will call gv_init for us, which inflates the glob
                  # don't know how to do this in general
                  $namespace->bless(\(my $foo))->can($name);
              }
              else {
                  confess "Don't know how to inflate a " . ref($entry_ref)
                        . " into a full coderef (perhaps you could use"
                        . " Package::Anon instead of a bare stash?)"
              }
  
              return *{ $namespace->{$name} }{CODE};
          }
          else {
              return undef;
          }
      }
  }
  
  sub get_or_add_symbol {
      my $self = shift;
      $self->get_symbol(@_, vivify => 1);
  }
  
  sub remove_symbol {
      my ($self, $variable) = @_;
  
      my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  
      # FIXME:
      # no doubt this is grossly inefficient and
      # could be done much easier and faster in XS
  
      my %desc = (
          SCALAR => { sigil => '$', type => 'SCALAR', name => $name },
          ARRAY  => { sigil => '@', type => 'ARRAY',  name => $name },
          HASH   => { sigil => '%', type => 'HASH',   name => $name },
          CODE   => { sigil => '&', type => 'CODE',   name => $name },
          IO     => { sigil => '',  type => 'IO',     name => $name },
      );
      confess "This should never ever ever happen" if !$desc{$type};
  
      my @types_to_store = grep { $type ne $_ && $self->has_symbol($desc{$_}) }
                                keys %desc;
      my %values = map { $_, $self->get_symbol($desc{$_}) } @types_to_store;
  
      $values{SCALAR} = $self->get_symbol($desc{SCALAR})
        if !defined $values{SCALAR}
          && $type ne 'SCALAR'
          && BROKEN_SCALAR_INITIALIZATION;
  
      $self->remove_glob($name);
  
      $self->add_symbol($desc{$_} => $values{$_})
          for grep { defined $values{$_} } keys %values;
  }
  
  sub list_all_symbols {
      my ($self, $type_filter) = @_;
  
      my $namespace = $self->namespace;
      if (HAS_ISA_CACHE) {
          return grep { $_ ne '::ISA::CACHE::' } keys %{$namespace}
              unless defined $type_filter;
      }
      else {
          return keys %{$namespace}
              unless defined $type_filter;
      }
  
      # NOTE:
      # or we can filter based on
      # type (SCALAR|ARRAY|HASH|CODE)
      if ($type_filter eq 'CODE') {
          return grep {
              # any non-typeglob in the symbol table is a constant or stub
              ref(\$namespace->{$_}) ne 'GLOB'
                  # regular subs are stored in the CODE slot of the typeglob
                  || defined(*{$namespace->{$_}}{CODE})
          } keys %{$namespace};
      }
      elsif ($type_filter eq 'SCALAR') {
          return grep {
              !(HAS_ISA_CACHE && $_ eq '::ISA::CACHE::') &&
              (BROKEN_SCALAR_INITIALIZATION
                  ? (ref(\$namespace->{$_}) eq 'GLOB'
                        && defined(${*{$namespace->{$_}}{'SCALAR'}}))
                  : (do {
                        my $entry = \$namespace->{$_};
                        ref($entry) eq 'GLOB'
                            && B::svref_2object($entry)->SV->isa('B::SV')
                    }))
          } keys %{$namespace};
      }
      else {
          return grep {
              ref(\$namespace->{$_}) eq 'GLOB'
                  && defined(*{$namespace->{$_}}{$type_filter})
          } keys %{$namespace};
      }
  }
  
  sub get_all_symbols {
      my ($self, $type_filter) = @_;
  
      my $namespace = $self->namespace;
      return { %{$namespace} } unless defined $type_filter;
  
      return {
          map { $_ => $self->get_symbol({name => $_, type => $type_filter}) }
              $self->list_all_symbols($type_filter)
      }
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Package::Stash::PP - pure perl implementation of the Package::Stash API
  
  =head1 VERSION
  
  version 0.35
  
  =head1 SYNOPSIS
  
    use Package::Stash;
  
  =head1 DESCRIPTION
  
  This is a backend for L<Package::Stash> implemented in pure perl, for those without a compiler or who would like to use this inline in scripts.
  
  =head1 BUGS
  
  =over 4
  
  =item * remove_symbol also replaces the associated typeglob
  
  This can cause unexpected behavior when doing manipulation at compile time -
  removing subroutines will still allow them to be called from within the package
  as subroutines (although they will not be available as methods). This can be
  considered a feature in some cases (this is how L<namespace::clean> works, for
  instance), but should not be relied upon - use C<remove_glob> directly if you
  want this behavior.
  
  =item * Some minor memory leaks
  
  The pure perl implementation has a couple minor memory leaks (see the TODO
  tests in t/20-leaks.t) that I'm having a hard time tracking down - these may be
  core perl bugs, it's hard to tell.
  
  =back
  
  Please report any bugs through RT: email
  C<bug-package-stash at rt.cpan.org>, or browse to
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Class::MOP::Package>
  
  This module is a factoring out of code that used to live here
  
  =back
  
  =head1 SUPPORT
  
  You can find this documentation for this module with the perldoc command.
  
      perldoc Package::Stash
  
  You can also look for information at:
  
  =over 4
  
  =item * AnnoCPAN: Annotated CPAN documentation
  
  L<http://annocpan.org/dist/Package-Stash>
  
  =item * CPAN Ratings
  
  L<http://cpanratings.perl.org/d/Package-Stash>
  
  =item * RT: CPAN's request tracker
  
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
  
  =item * Search CPAN
  
  L<http://search.cpan.org/dist/Package-Stash>
  
  =back
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy at tozt dot net>
  
  Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
  Moose Cabal.
  
  =for Pod::Coverage BROKEN_ISA_ASSIGNMENT
  add_symbol
  get_all_symbols
  get_or_add_symbol
  get_symbol
  has_symbol
  list_all_symbols
  name
  namespace
  new
  remove_glob
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy@tozt.net>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Jesse Luehrs.
  
  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
PACKAGE_STASH_PP

$fatpacked{"Path/Class.pm"} = <<'PATH_CLASS';
  use strict;
  
  package Path::Class;
  {
    $Path::Class::VERSION = '0.32';
  }
  
  {
    ## no critic
    no strict 'vars';
    @ISA = qw(Exporter);
    @EXPORT    = qw(file dir);
    @EXPORT_OK = qw(file dir foreign_file foreign_dir tempdir);
  }
  
  use Exporter;
  use Path::Class::File;
  use Path::Class::Dir;
  use File::Temp ();
  
  sub file { Path::Class::File->new(@_) }
  sub dir  { Path::Class::Dir ->new(@_) }
  sub foreign_file { Path::Class::File->new_foreign(@_) }
  sub foreign_dir  { Path::Class::Dir ->new_foreign(@_) }
  sub tempdir { Path::Class::Dir->new(File::Temp::tempdir(@_)) }
  
  
  1;
  __END__
  
  =head1 NAME
  
  Path::Class - Cross-platform path specification manipulation
  
  =head1 VERSION
  
  version 0.32
  
  =head1 SYNOPSIS
  
    use Path::Class;
    
    my $dir  = dir('foo', 'bar');       # Path::Class::Dir object
    my $file = file('bob', 'file.txt'); # Path::Class::File object
    
    # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc.
    print "dir: $dir\n";
    
    # Stringifies to 'bob/file.txt' on Unix, 'bob\file.txt' on Windows
    print "file: $file\n";
    
    my $subdir  = $dir->subdir('baz');  # foo/bar/baz
    my $parent  = $subdir->parent;      # foo/bar
    my $parent2 = $parent->parent;      # foo
    
    my $dir2 = $file->dir;              # bob
  
    # Work with foreign paths
    use Path::Class qw(foreign_file foreign_dir);
    my $file = foreign_file('Mac', ':foo:file.txt');
    print $file->dir;                   # :foo:
    print $file->as_foreign('Win32');   # foo\file.txt
    
    # Interact with the underlying filesystem:
    
    # $dir_handle is an IO::Dir object
    my $dir_handle = $dir->open or die "Can't read $dir: $!";
    
    # $file_handle is an IO::File object
    my $file_handle = $file->open($mode) or die "Can't read $file: $!";
  
  =head1 DESCRIPTION
  
  C<Path::Class> is a module for manipulation of file and directory
  specifications (strings describing their locations, like
  C<'/home/ken/foo.txt'> or C<'C:\Windows\Foo.txt'>) in a cross-platform
  manner.  It supports pretty much every platform Perl runs on,
  including Unix, Windows, Mac, VMS, Epoc, Cygwin, OS/2, and NetWare.
  
  The well-known module L<File::Spec> also provides this service, but
  it's sort of awkward to use well, so people sometimes avoid it, or use
  it in a way that won't actually work properly on platforms
  significantly different than the ones they've tested their code on.
  
  In fact, C<Path::Class> uses C<File::Spec> internally, wrapping all
  the unsightly details so you can concentrate on your application code.
  Whereas C<File::Spec> provides functions for some common path
  manipulations, C<Path::Class> provides an object-oriented model of the
  world of path specifications and their underlying semantics.
  C<File::Spec> doesn't create any objects, and its classes represent
  the different ways in which paths must be manipulated on various
  platforms (not a very intuitive concept).  C<Path::Class> creates
  objects representing files and directories, and provides methods that
  relate them to each other.  For instance, the following C<File::Spec>
  code:
  
   my $absolute = File::Spec->file_name_is_absolute(
                    File::Spec->catfile( @dirs, $file )
                  );
  
  can be written using C<Path::Class> as
  
   my $absolute = Path::Class::File->new( @dirs, $file )->is_absolute;
  
  or even as 
  
   my $absolute = file( @dirs, $file )->is_absolute;
  
  Similar readability improvements should happen all over the place when
  using C<Path::Class>.
  
  Using C<Path::Class> can help solve real problems in your code too -
  for instance, how many people actually take the "volume" (like C<C:>
  on Windows) into account when writing C<File::Spec>-using code?  I
  thought not.  But if you use C<Path::Class>, your file and directory objects
  will know what volumes they refer to and do the right thing.
  
  The guts of the C<Path::Class> code live in the L<Path::Class::File>
  and L<Path::Class::Dir> modules, so please see those
  modules' documentation for more details about how to use them.
  
  =head2 EXPORT
  
  The following functions are exported by default.
  
  =over 4
  
  =item file
  
  A synonym for C<< Path::Class::File->new >>.
  
  =item dir
  
  A synonym for C<< Path::Class::Dir->new >>.
  
  =back
  
  If you would like to prevent their export, you may explicitly pass an
  empty list to perl's C<use>, i.e. C<use Path::Class ()>.
  
  The following are exported only on demand.
  
  =over 4
  
  =item foreign_file
  
  A synonym for C<< Path::Class::File->new_foreign >>.
  
  =item foreign_dir
  
  A synonym for C<< Path::Class::Dir->new_foreign >>.
  
  =item tempdir
  
  Create a new Path::Class::Dir instance pointed to temporary directory.
  
    my $temp = Path::Class::tempdir(CLEANUP => 1);
  
  A synonym for C<< Path::Class::Dir->new(File::Temp::tempdir(@_)) >>.
  
  =back
  
  =head1 Notes on Cross-Platform Compatibility
  
  Although it is much easier to write cross-platform-friendly code with
  this module than with C<File::Spec>, there are still some issues to be
  aware of.
  
  =over 4
  
  =item *
  
  On some platforms, notably VMS and some older versions of DOS (I think),
  all filenames must have an extension.  Thus if you create a file
  called F<foo/bar> and then ask for a list of files in the directory
  F<foo>, you may find a file called F<bar.> instead of the F<bar> you
  were expecting.  Thus it might be a good idea to use an extension in
  the first place.
  
  =back
  
  =head1 AUTHOR
  
  Ken Williams, KWILLIAMS@cpan.org
  
  =head1 COPYRIGHT
  
  Copyright (c) Ken Williams.  All rights reserved.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  
  =head1 SEE ALSO
  
  L<Path::Class::Dir>, L<Path::Class::File>, L<File::Spec>
  
  =cut
PATH_CLASS

$fatpacked{"Path/Class/Dir.pm"} = <<'PATH_CLASS_DIR';
  use strict;
  
  package Path::Class::Dir;
  {
    $Path::Class::Dir::VERSION = '0.32';
  }
  
  use Path::Class::File;
  use Carp();
  use base qw(Path::Class::Entity);
  
  use IO::Dir ();
  use File::Path ();
  use File::Temp ();
  use Scalar::Util ();
  
  # updir & curdir on the local machine, for screening them out in
  # children().  Note that they don't respect 'foreign' semantics.
  my $Updir  = __PACKAGE__->_spec->updir;
  my $Curdir = __PACKAGE__->_spec->curdir;
  
  sub new {
    my $self = shift->SUPER::new();
  
    # If the only arg is undef, it's probably a mistake.  Without this
    # special case here, we'd return the root directory, which is a
    # lousy thing to do to someone when they made a mistake.  Return
    # undef instead.
    return if @_==1 && !defined($_[0]);
  
    my $s = $self->_spec;
    
    my $first = (@_ == 0     ? $s->curdir :
  	       $_[0] eq '' ? (shift, $s->rootdir) :
  	       shift()
  	      );
    
    $self->{dirs} = [];
    if ( Scalar::Util::blessed($first) && $first->isa("Path::Class::Dir") ) {
      $self->{volume} = $first->{volume};
      push @{$self->{dirs}}, @{$first->{dirs}};
    }
    else {
      ($self->{volume}, my $dirs) = $s->splitpath( $s->canonpath("$first") , 1);
      push @{$self->{dirs}}, $dirs eq $s->rootdir ? "" : $s->splitdir($dirs);
    }
  
    push @{$self->{dirs}}, map {
      Scalar::Util::blessed($_) && $_->isa("Path::Class::Dir")
        ? @{$_->{dirs}}
        : $s->splitdir($_)
    } @_;
  
  
    return $self;
  }
  
  sub file_class { "Path::Class::File" }
  
  sub is_dir { 1 }
  
  sub as_foreign {
    my ($self, $type) = @_;
  
    my $foreign = do {
      local $self->{file_spec_class} = $self->_spec_class($type);
      $self->SUPER::new;
    };
    
    # Clone internal structure
    $foreign->{volume} = $self->{volume};
    my ($u, $fu) = ($self->_spec->updir, $foreign->_spec->updir);
    $foreign->{dirs} = [ map {$_ eq $u ? $fu : $_} @{$self->{dirs}}];
    return $foreign;
  }
  
  sub stringify {
    my $self = shift;
    my $s = $self->_spec;
    return $s->catpath($self->{volume},
  		     $s->catdir(@{$self->{dirs}}),
  		     '');
  }
  
  sub volume { shift()->{volume} }
  
  sub file {
    local $Path::Class::Foreign = $_[0]->{file_spec_class} if $_[0]->{file_spec_class};
    return $_[0]->file_class->new(@_);
  }
  
  sub basename { shift()->{dirs}[-1] }
  
  sub dir_list {
    my $self = shift;
    my $d = $self->{dirs};
    return @$d unless @_;
    
    my $offset = shift;
    if ($offset < 0) { $offset = $#$d + $offset + 1 }
    
    return wantarray ? @$d[$offset .. $#$d] : $d->[$offset] unless @_;
    
    my $length = shift;
    if ($length < 0) { $length = $#$d + $length + 1 - $offset }
    return @$d[$offset .. $length + $offset - 1];
  }
  
  sub components {
    my $self = shift;
    return $self->dir_list(@_);
  }
  
  sub subdir {
    my $self = shift;
    return $self->new($self, @_);
  }
  
  sub parent {
    my $self = shift;
    my $dirs = $self->{dirs};
    my ($curdir, $updir) = ($self->_spec->curdir, $self->_spec->updir);
  
    if ($self->is_absolute) {
      my $parent = $self->new($self);
      pop @{$parent->{dirs}} if @$dirs > 1;
      return $parent;
  
    } elsif ($self eq $curdir) {
      return $self->new($updir);
  
    } elsif (!grep {$_ ne $updir} @$dirs) {  # All updirs
      return $self->new($self, $updir); # Add one more
  
    } elsif (@$dirs == 1) {
      return $self->new($curdir);
  
    } else {
      my $parent = $self->new($self);
      pop @{$parent->{dirs}};
      return $parent;
    }
  }
  
  sub relative {
    # File::Spec->abs2rel before version 3.13 returned the empty string
    # when the two paths were equal - work around it here.
    my $self = shift;
    my $rel = $self->_spec->abs2rel($self->stringify, @_);
    return $self->new( length $rel ? $rel : $self->_spec->curdir );
  }
  
  sub open  { IO::Dir->new(@_) }
  sub mkpath { File::Path::mkpath(shift()->stringify, @_) }
  sub rmtree { File::Path::rmtree(shift()->stringify, @_) }
  
  sub remove {
    rmdir( shift() );
  }
  
  sub traverse {
    my $self = shift;
    my ($callback, @args) = @_;
    my @children = $self->children;
    return $self->$callback(
      sub {
        my @inner_args = @_;
        return map { $_->traverse($callback, @inner_args) } @children;
      },
      @args
    );
  }
  
  sub traverse_if {
    my $self = shift;
    my ($callback, $condition, @args) = @_;
    my @children = grep { $condition->($_) } $self->children;
    return $self->$callback(
      sub {
        my @inner_args = @_;
        return map { $_->traverse_if($callback, $condition, @inner_args) } @children;
      },
      @args
    );
  }
  
  sub recurse {
    my $self = shift;
    my %opts = (preorder => 1, depthfirst => 0, @_);
    
    my $callback = $opts{callback}
      or Carp::croak( "Must provide a 'callback' parameter to recurse()" );
    
    my @queue = ($self);
    
    my $visit_entry;
    my $visit_dir = 
      $opts{depthfirst} && $opts{preorder}
      ? sub {
        my $dir = shift;
        my $ret = $callback->($dir);
        unless( ($ret||'') eq $self->PRUNE ) {
            unshift @queue, $dir->children;
        }
      }
      : $opts{preorder}
      ? sub {
        my $dir = shift;
        my $ret = $callback->($dir);
        unless( ($ret||'') eq $self->PRUNE ) {
            push @queue, $dir->children;
        }
      }
      : sub {
        my $dir = shift;
        $visit_entry->($_) foreach $dir->children;
        $callback->($dir);
      };
    
    $visit_entry = sub {
      my $entry = shift;
      if ($entry->is_dir) { $visit_dir->($entry) } # Will call $callback
      else { $callback->($entry) }
    };
    
    while (@queue) {
      $visit_entry->( shift @queue );
    }
  }
  
  sub children {
    my ($self, %opts) = @_;
    
    my $dh = $self->open or Carp::croak( "Can't open directory $self: $!" );
    
    my @out;
    while (defined(my $entry = $dh->read)) {
      next if !$opts{all} && $self->_is_local_dot_dir($entry);
      next if ($opts{no_hidden} && $entry =~ /^\./);
      push @out, $self->file($entry);
      $out[-1] = $self->subdir($entry) if -d $out[-1];
    }
    return @out;
  }
  
  sub _is_local_dot_dir {
    my $self = shift;
    my $dir  = shift;
  
    return ($dir eq $Updir or $dir eq $Curdir);
  }
  
  sub next {
    my $self = shift;
    unless ($self->{dh}) {
      $self->{dh} = $self->open or Carp::croak( "Can't open directory $self: $!" );
    }
    
    my $next = $self->{dh}->read;
    unless (defined $next) {
      delete $self->{dh};
      ## no critic
      return undef;
    }
    
    # Figure out whether it's a file or directory
    my $file = $self->file($next);
    $file = $self->subdir($next) if -d $file;
    return $file;
  }
  
  sub subsumes {
    my ($self, $other) = @_;
    die "No second entity given to subsumes()" unless $other;
    
    $other = $self->new($other) unless UNIVERSAL::isa($other, __PACKAGE__);
    $other = $other->dir unless $other->is_dir;
    
    if ($self->is_absolute) {
      $other = $other->absolute;
    } elsif ($other->is_absolute) {
      $self = $self->absolute;
    }
  
    $self = $self->cleanup;
    $other = $other->cleanup;
  
    if ($self->volume) {
      return 0 unless $other->volume eq $self->volume;
    }
  
    # The root dir subsumes everything (but ignore the volume because
    # we've already checked that)
    return 1 if "@{$self->{dirs}}" eq "@{$self->new('')->{dirs}}";
    
    my $i = 0;
    while ($i <= $#{ $self->{dirs} }) {
      return 0 if $i > $#{ $other->{dirs} };
      return 0 if $self->{dirs}[$i] ne $other->{dirs}[$i];
      $i++;
    }
    return 1;
  }
  
  sub contains {
    my ($self, $other) = @_;
    return !!(-d $self and (-e $other or -l $other) and $self->subsumes($other));
  }
  
  sub tempfile {
    my $self = shift;
    return File::Temp::tempfile(@_, DIR => $self->stringify);
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Path::Class::Dir - Objects representing directories
  
  =head1 VERSION
  
  version 0.32
  
  =head1 SYNOPSIS
  
    use Path::Class qw(dir);  # Export a short constructor
    
    my $dir = dir('foo', 'bar');       # Path::Class::Dir object
    my $dir = Path::Class::Dir->new('foo', 'bar');  # Same thing
    
    # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc.
    print "dir: $dir\n";
    
    if ($dir->is_absolute) { ... }
    if ($dir->is_relative) { ... }
    
    my $v = $dir->volume; # Could be 'C:' on Windows, empty string
                          # on Unix, 'Macintosh HD:' on Mac OS
    
    $dir->cleanup; # Perform logical cleanup of pathname
    $dir->resolve; # Perform physical cleanup of pathname
    
    my $file = $dir->file('file.txt'); # A file in this directory
    my $subdir = $dir->subdir('george'); # A subdirectory
    my $parent = $dir->parent; # The parent directory, 'foo'
    
    my $abs = $dir->absolute; # Transform to absolute path
    my $rel = $abs->relative; # Transform to relative path
    my $rel = $abs->relative('/foo'); # Relative to /foo
    
    print $dir->as_foreign('Mac');   # :foo:bar:
    print $dir->as_foreign('Win32'); #  foo\bar
  
    # Iterate with IO::Dir methods:
    my $handle = $dir->open;
    while (my $file = $handle->read) {
      $file = $dir->file($file);  # Turn into Path::Class::File object
      ...
    }
    
    # Iterate with Path::Class methods:
    while (my $file = $dir->next) {
      # $file is a Path::Class::File or Path::Class::Dir object
      ...
    }
  
  
  =head1 DESCRIPTION
  
  The C<Path::Class::Dir> class contains functionality for manipulating
  directory names in a cross-platform way.
  
  =head1 METHODS
  
  =over 4
  
  =item $dir = Path::Class::Dir->new( <dir1>, <dir2>, ... )
  
  =item $dir = dir( <dir1>, <dir2>, ... )
  
  Creates a new C<Path::Class::Dir> object and returns it.  The
  arguments specify names of directories which will be joined to create
  a single directory object.  A volume may also be specified as the
  first argument, or as part of the first argument.  You can use
  platform-neutral syntax:
  
    my $dir = dir( 'foo', 'bar', 'baz' );
  
  or platform-native syntax:
  
    my $dir = dir( 'foo/bar/baz' );
  
  or a mixture of the two:
  
    my $dir = dir( 'foo/bar', 'baz' );
  
  All three of the above examples create relative paths.  To create an
  absolute path, either use the platform native syntax for doing so:
  
    my $dir = dir( '/var/tmp' );
  
  or use an empty string as the first argument:
  
    my $dir = dir( '', 'var', 'tmp' );
  
  If the second form seems awkward, that's somewhat intentional - paths
  like C</var/tmp> or C<\Windows> aren't cross-platform concepts in the
  first place (many non-Unix platforms don't have a notion of a "root
  directory"), so they probably shouldn't appear in your code if you're
  trying to be cross-platform.  The first form is perfectly natural,
  because paths like this may come from config files, user input, or
  whatever.
  
  As a special case, since it doesn't otherwise mean anything useful and
  it's convenient to define this way, C<< Path::Class::Dir->new() >> (or
  C<dir()>) refers to the current directory (C<< File::Spec->curdir >>).
  To get the current directory as an absolute path, do C<<
  dir()->absolute >>.
  
  Finally, as another special case C<dir(undef)> will return undef,
  since that's usually an accident on the part of the caller, and
  returning the root directory would be a nasty surprise just asking for
  trouble a few lines later.
  
  =item $dir->stringify
  
  This method is called internally when a C<Path::Class::Dir> object is
  used in a string context, so the following are equivalent:
  
    $string = $dir->stringify;
    $string = "$dir";
  
  =item $dir->volume
  
  Returns the volume (e.g. C<C:> on Windows, C<Macintosh HD:> on Mac OS,
  etc.) of the directory object, if any.  Otherwise, returns the empty
  string.
  
  =item $dir->basename
  
  Returns the last directory name of the path as a string.
  
  =item $dir->is_dir
  
  Returns a boolean value indicating whether this object represents a
  directory.  Not surprisingly, L<Path::Class::File> objects always
  return false, and C<Path::Class::Dir> objects always return true.
  
  =item $dir->is_absolute
  
  Returns true or false depending on whether the directory refers to an
  absolute path specifier (like C</usr/local> or C<\Windows>).
  
  =item $dir->is_relative
  
  Returns true or false depending on whether the directory refers to a
  relative path specifier (like C<lib/foo> or C<./dir>).
  
  =item $dir->cleanup
  
  Performs a logical cleanup of the file path.  For instance:
  
    my $dir = dir('/foo//baz/./foo')->cleanup;
    # $dir now represents '/foo/baz/foo';
  
  =item $dir->resolve
  
  Performs a physical cleanup of the file path.  For instance:
  
    my $dir = dir('/foo//baz/../foo')->resolve;
    # $dir now represents '/foo/foo', assuming no symlinks
  
  This actually consults the filesystem to verify the validity of the
  path.
  
  =item $file = $dir->file( <dir1>, <dir2>, ..., <file> )
  
  Returns a L<Path::Class::File> object representing an entry in C<$dir>
  or one of its subdirectories.  Internally, this just calls C<<
  Path::Class::File->new( @_ ) >>.
  
  =item $subdir = $dir->subdir( <dir1>, <dir2>, ... )
  
  Returns a new C<Path::Class::Dir> object representing a subdirectory
  of C<$dir>.
  
  =item $parent = $dir->parent
  
  Returns the parent directory of C<$dir>.  Note that this is the
  I<logical> parent, not necessarily the physical parent.  It really
  means we just chop off entries from the end of the directory list
  until we cain't chop no more.  If the directory is relative, we start
  using the relative forms of parent directories.
  
  The following code demonstrates the behavior on absolute and relative
  directories:
  
    $dir = dir('/foo/bar');
    for (1..6) {
      print "Absolute: $dir\n";
      $dir = $dir->parent;
    }
    
    $dir = dir('foo/bar');
    for (1..6) {
      print "Relative: $dir\n";
      $dir = $dir->parent;
    }
    
    ########### Output on Unix ################
    Absolute: /foo/bar
    Absolute: /foo
    Absolute: /
    Absolute: /
    Absolute: /
    Absolute: /
    Relative: foo/bar
    Relative: foo
    Relative: .
    Relative: ..
    Relative: ../..
    Relative: ../../..
  
  =item @list = $dir->children
  
  Returns a list of L<Path::Class::File> and/or C<Path::Class::Dir>
  objects listed in this directory, or in scalar context the number of
  such objects.  Obviously, it is necessary for C<$dir> to
  exist and be readable in order to find its children.
  
  Note that the children are returned as subdirectories of C<$dir>,
  i.e. the children of F<foo> will be F<foo/bar> and F<foo/baz>, not
  F<bar> and F<baz>.
  
  Ordinarily C<children()> will not include the I<self> and I<parent>
  entries C<.> and C<..> (or their equivalents on non-Unix systems),
  because that's like I'm-my-own-grandpa business.  If you do want all
  directory entries including these special ones, pass a true value for
  the C<all> parameter:
  
    @c = $dir->children(); # Just the children
    @c = $dir->children(all => 1); # All entries
  
  In addition, there's a C<no_hidden> parameter that will exclude all
  normally "hidden" entries - on Unix this means excluding all entries
  that begin with a dot (C<.>):
  
    @c = $dir->children(no_hidden => 1); # Just normally-visible entries
  
  
  =item $abs = $dir->absolute
  
  Returns a C<Path::Class::Dir> object representing C<$dir> as an
  absolute path.  An optional argument, given as either a string or a
  C<Path::Class::Dir> object, specifies the directory to use as the base
  of relativity - otherwise the current working directory will be used.
  
  =item $rel = $dir->relative
  
  Returns a C<Path::Class::Dir> object representing C<$dir> as a
  relative path.  An optional argument, given as either a string or a
  C<Path::Class::Dir> object, specifies the directory to use as the base
  of relativity - otherwise the current working directory will be used.
  
  =item $boolean = $dir->subsumes($other)
  
  Returns true if this directory spec subsumes the other spec, and false
  otherwise.  Think of "subsumes" as "contains", but we only look at the
  I<specs>, not whether C<$dir> actually contains C<$other> on the
  filesystem.
  
  The C<$other> argument may be a C<Path::Class::Dir> object, a
  L<Path::Class::File> object, or a string.  In the latter case, we
  assume it's a directory.
  
    # Examples:
    dir('foo/bar' )->subsumes(dir('foo/bar/baz'))  # True
    dir('/foo/bar')->subsumes(dir('/foo/bar/baz')) # True
    dir('foo/bar' )->subsumes(dir('bar/baz'))      # False
    dir('/foo/bar')->subsumes(dir('foo/bar'))      # False
  
  
  =item $boolean = $dir->contains($other)
  
  Returns true if this directory actually contains C<$other> on the
  filesystem.  C<$other> doesn't have to be a direct child of C<$dir>,
  it just has to be subsumed.
  
  =item $foreign = $dir->as_foreign($type)
  
  Returns a C<Path::Class::Dir> object representing C<$dir> as it would
  be specified on a system of type C<$type>.  Known types include
  C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
  there is a subclass of C<File::Spec>.
  
  Any generated objects (subdirectories, files, parents, etc.) will also
  retain this type.
  
  =item $foreign = Path::Class::Dir->new_foreign($type, @args)
  
  Returns a C<Path::Class::Dir> object representing C<$dir> as it would
  be specified on a system of type C<$type>.  Known types include
  C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
  there is a subclass of C<File::Spec>.
  
  The arguments in C<@args> are the same as they would be specified in
  C<new()>.
  
  =item @list = $dir->dir_list([OFFSET, [LENGTH]])
  
  Returns the list of strings internally representing this directory
  structure.  Each successive member of the list is understood to be an
  entry in its predecessor's directory list.  By contract, C<<
  Path::Class->new( $dir->dir_list ) >> should be equivalent to C<$dir>.
  
  The semantics of this method are similar to Perl's C<splice> or
  C<substr> functions; they return C<LENGTH> elements starting at
  C<OFFSET>.  If C<LENGTH> is omitted, returns all the elements starting
  at C<OFFSET> up to the end of the list.  If C<LENGTH> is negative,
  returns the elements from C<OFFSET> onward except for C<-LENGTH>
  elements at the end.  If C<OFFSET> is negative, it counts backward
  C<OFFSET> elements from the end of the list.  If C<OFFSET> and
  C<LENGTH> are both omitted, the entire list is returned.
  
  In a scalar context, C<dir_list()> with no arguments returns the
  number of entries in the directory list; C<dir_list(OFFSET)> returns
  the single element at that offset; C<dir_list(OFFSET, LENGTH)> returns
  the final element that would have been returned in a list context.
  
  =item $dir->components
  
  Identical to c<dir_list()>.  It exists because there's an analogous
  method C<dir_list()> in the C<Path::Class::File> class that also
  returns the basename string, so this method lets someone call
  C<components()> without caring whether the object is a file or a
  directory.
  
  =item $fh = $dir->open()
  
  Passes C<$dir> to C<< IO::Dir->open >> and returns the result as an
  L<IO::Dir> object.  If the opening fails, C<undef> is returned and
  C<$!> is set.
  
  =item $dir->mkpath($verbose, $mode)
  
  Passes all arguments, including C<$dir>, to C<< File::Path::mkpath()
  >> and returns the result (a list of all directories created).
  
  =item $dir->rmtree($verbose, $cautious)
  
  Passes all arguments, including C<$dir>, to C<< File::Path::rmtree()
  >> and returns the result (the number of files successfully deleted).
  
  =item $dir->remove()
  
  Removes the directory, which must be empty.  Returns a boolean value
  indicating whether or not the directory was successfully removed.
  This method is mainly provided for consistency with
  C<Path::Class::File>'s C<remove()> method.
  
  =item $dir->tempfile(...)
  
  An interface to L<File::Temp>'s C<tempfile()> function.  Just like
  that function, if you call this in a scalar context, the return value
  is the filehandle and the file is C<unlink>ed as soon as possible
  (which is immediately on Unix-like platforms).  If called in a list
  context, the return values are the filehandle and the filename.
  
  The given directory is passed as the C<DIR> parameter.
  
  Here's an example of pretty good usage which doesn't allow race
  conditions, won't leave yucky tempfiles around on your filesystem,
  etc.:
  
    my $fh = $dir->tempfile;
    print $fh "Here's some data...\n";
    seek($fh, 0, 0);
    while (<$fh>) { do something... }
  
  Or in combination with a C<fork>:
  
    my $fh = $dir->tempfile;
    print $fh "Here's some more data...\n";
    seek($fh, 0, 0);
    if ($pid=fork()) {
      wait;
    } else {
      something($_) while <$fh>;
    }
  
  
  =item $dir_or_file = $dir->next()
  
  A convenient way to iterate through directory contents.  The first
  time C<next()> is called, it will C<open()> the directory and read the
  first item from it, returning the result as a C<Path::Class::Dir> or
  L<Path::Class::File> object (depending, of course, on its actual
  type).  Each subsequent call to C<next()> will simply iterate over the
  directory's contents, until there are no more items in the directory,
  and then the undefined value is returned.  For example, to iterate
  over all the regular files in a directory:
  
    while (my $file = $dir->next) {
      next unless -f $file;
      my $fh = $file->open('r') or die "Can't read $file: $!";
      ...
    }
  
  If an error occurs when opening the directory (for instance, it
  doesn't exist or isn't readable), C<next()> will throw an exception
  with the value of C<$!>.
  
  =item $dir->traverse( sub { ... }, @args )
  
  Calls the given callback for the root, passing it a continuation
  function which, when called, will call this recursively on each of its
  children. The callback function should be of the form:
  
    sub {
      my ($child, $cont, @args) = @_;
      # ...
    }
  
  For instance, to calculate the number of files in a directory, you
  can do this:
  
    my $nfiles = $dir->traverse(sub {
      my ($child, $cont) = @_;
      return sum($cont->(), ($child->is_dir ? 0 : 1));
    });
  
  or to calculate the maximum depth of a directory:
  
    my $depth = $dir->traverse(sub {
      my ($child, $cont, $depth) = @_;
      return max($cont->($depth + 1), $depth);
    }, 0);
  
  You can also choose not to call the callback in certain situations:
  
    $dir->traverse(sub {
      my ($child, $cont) = @_;
      return if -l $child; # don't follow symlinks
      # do something with $child
      return $cont->();
    });
  
  =item $dir->traverse_if( sub { ... }, sub { ... }, @args )
  
  traverse with additional "should I visit this child" callback.
  Particularly useful in case examined tree contains inaccessible
  directories.
  
  Canonical example:
  
    $dir->traverse_if(
      sub {
         my ($child, $cont) = @_;
         # do something with $child
         return $cont->();
      }, 
      sub {
         my ($child) = @_;
         # Process only readable items
         return -r $child;
      });
  
  Second callback gets single parameter: child. Only children for
  which it returns true will be processed by the first callback.
  
  Remaining parameters are interpreted as in traverse, in particular
  C<traverse_if(callback, sub { 1 }, @args> is equivalent to
  C<traverse(callback, @args)>.
  
  =item $dir->recurse( callback => sub {...} )
  
  Iterates through this directory and all of its children, and all of
  its children's children, etc., calling the C<callback> subroutine for
  each entry.  This is a lot like what the L<File::Find> module does,
  and of course C<File::Find> will work fine on L<Path::Class> objects,
  but the advantage of the C<recurse()> method is that it will also feed
  your callback routine C<Path::Class> objects rather than just pathname
  strings.
  
  The C<recurse()> method requires a C<callback> parameter specifying
  the subroutine to invoke for each entry.  It will be passed the
  C<Path::Class> object as its first argument.
  
  C<recurse()> also accepts two boolean parameters, C<depthfirst> and
  C<preorder> that control the order of recursion.  The default is a
  preorder, breadth-first search, i.e. C<< depthfirst => 0, preorder => 1 >>.
  At the time of this writing, all combinations of these two parameters
  are supported I<except> C<< depthfirst => 0, preorder => 0 >>.
  
  C<callback> is normally not required to return any value. If it
  returns special constant C<Path::Class::Entity::PRUNE()> (more easily
  available as C<$item->PRUNE>),  no children of analyzed
  item will be analyzed (mostly as if you set C<$File::Find::prune=1>). Of course
  pruning is available only in C<preorder>, in postorder return value
  has no effect.
  
  =item $st = $file->stat()
  
  Invokes C<< File::stat::stat() >> on this directory and returns a
  C<File::stat> object representing the result.
  
  =item $st = $file->lstat()
  
  Same as C<stat()>, but if C<$file> is a symbolic link, C<lstat()>
  stats the link instead of the directory the link points to.
  
  =item $class = $file->file_class()
  
  Returns the class which should be used to create file objects.
  
  Generally overridden whenever this class is subclassed.
  
  =back
  
  =head1 AUTHOR
  
  Ken Williams, kwilliams@cpan.org
  
  =head1 SEE ALSO
  
  L<Path::Class>, L<Path::Class::File>, L<File::Spec>
  
  =cut
PATH_CLASS_DIR

$fatpacked{"Path/Class/Entity.pm"} = <<'PATH_CLASS_ENTITY';
  use strict;
  
  package Path::Class::Entity;
  {
    $Path::Class::Entity::VERSION = '0.32';
  }
  
  use File::Spec 3.26;
  use File::stat ();
  use Cwd;
  use Carp();
  
  use overload
    (
     q[""] => 'stringify',
     'bool' => 'boolify',
     fallback => 1,
    );
  
  sub new {
    my $from = shift;
    my ($class, $fs_class) = (ref($from)
  			    ? (ref $from, $from->{file_spec_class})
  			    : ($from, $Path::Class::Foreign));
    return bless {file_spec_class => $fs_class}, $class;
  }
  
  sub is_dir { 0 }
  
  sub _spec_class {
    my ($class, $type) = @_;
  
    die "Invalid system type '$type'" unless ($type) = $type =~ /^(\w+)$/;  # Untaint
    my $spec = "File::Spec::$type";
    ## no critic
    eval "require $spec; 1" or die $@;
    return $spec;
  }
  
  sub new_foreign {
    my ($class, $type) = (shift, shift);
    local $Path::Class::Foreign = $class->_spec_class($type);
    return $class->new(@_);
  }
  
  sub _spec { (ref($_[0]) && $_[0]->{file_spec_class}) || 'File::Spec' }
  
  sub boolify { 1 }
    
  sub is_absolute { 
    # 5.6.0 has a bug with regexes and stringification that's ticked by
    # file_name_is_absolute().  Help it along with an explicit stringify().
    $_[0]->_spec->file_name_is_absolute($_[0]->stringify) 
  }
  
  sub is_relative { ! $_[0]->is_absolute }
  
  sub cleanup {
    my $self = shift;
    my $cleaned = $self->new( $self->_spec->canonpath("$self") );
    %$self = %$cleaned;
    return $self;
  }
  
  sub resolve {
    my $self = shift;
    Carp::croak($! . " $self") unless -e $self;  # No such file or directory
    my $cleaned = $self->new( scalar Cwd::realpath($self->stringify) );
  
    # realpath() always returns absolute path, kind of annoying
    $cleaned = $cleaned->relative if $self->is_relative;
  
    %$self = %$cleaned;
    return $self;
  }
  
  sub absolute {
    my $self = shift;
    return $self if $self->is_absolute;
    return $self->new($self->_spec->rel2abs($self->stringify, @_));
  }
  
  sub relative {
    my $self = shift;
    return $self->new($self->_spec->abs2rel($self->stringify, @_));
  }
  
  sub stat  { File::stat::stat("$_[0]") }
  sub lstat { File::stat::lstat("$_[0]") }
  
  sub PRUNE { return \&PRUNE; }
  
  1;
  __END__
  
  =head1 NAME
  
  Path::Class::Entity - Base class for files and directories
  
  =head1 VERSION
  
  version 0.32
  
  =head1 DESCRIPTION
  
  This class is the base class for C<Path::Class::File> and
  C<Path::Class::Dir>, it is not used directly by callers.
  
  =head1 AUTHOR
  
  Ken Williams, kwilliams@cpan.org
  
  =head1 SEE ALSO
  
  Path::Class
  
  =cut
PATH_CLASS_ENTITY

$fatpacked{"Path/Class/File.pm"} = <<'PATH_CLASS_FILE';
  use strict;
  
  package Path::Class::File;
  {
    $Path::Class::File::VERSION = '0.32';
  }
  
  use Path::Class::Dir;
  use base qw(Path::Class::Entity);
  use Carp;
  
  use IO::File ();
  
  sub new {
    my $self = shift->SUPER::new;
    my $file = pop();
    my @dirs = @_;
  
    my ($volume, $dirs, $base) = $self->_spec->splitpath($file);
    
    if (length $dirs) {
      push @dirs, $self->_spec->catpath($volume, $dirs, '');
    }
    
    $self->{dir}  = @dirs ? $self->dir_class->new(@dirs) : undef;
    $self->{file} = $base;
    
    return $self;
  }
  
  sub dir_class { "Path::Class::Dir" }
  
  sub as_foreign {
    my ($self, $type) = @_;
    local $Path::Class::Foreign = $self->_spec_class($type);
    my $foreign = ref($self)->SUPER::new;
    $foreign->{dir} = $self->{dir}->as_foreign($type) if defined $self->{dir};
    $foreign->{file} = $self->{file};
    return $foreign;
  }
  
  sub stringify {
    my $self = shift;
    return $self->{file} unless defined $self->{dir};
    return $self->_spec->catfile($self->{dir}->stringify, $self->{file});
  }
  
  sub dir {
    my $self = shift;
    return $self->{dir} if defined $self->{dir};
    return $self->dir_class->new($self->_spec->curdir);
  }
  BEGIN { *parent = \&dir; }
  
  sub volume {
    my $self = shift;
    return '' unless defined $self->{dir};
    return $self->{dir}->volume;
  }
  
  sub components {
    my $self = shift;
    die "Arguments are not currently supported by File->components()" if @_;
    return ($self->dir->components, $self->basename);
  }
  
  sub basename { shift->{file} }
  sub open  { IO::File->new(@_) }
  
  sub openr { $_[0]->open('r') or croak "Can't read $_[0]: $!"  }
  sub openw { $_[0]->open('w') or croak "Can't write to $_[0]: $!" }
  sub opena { $_[0]->open('a') or croak "Can't append to $_[0]: $!" }
  
  sub touch {
    my $self = shift;
    if (-e $self) {
      my $now = time();
      utime $now, $now, $self;
    } else {
      $self->openw;
    }
  }
  
  sub slurp {
    my ($self, %args) = @_;
    my $iomode = $args{iomode} || 'r';
    my $fh = $self->open($iomode) or croak "Can't read $self: $!";
  
    if (wantarray) {
      my @data = <$fh>;
      chomp @data if $args{chomped} or $args{chomp};
  
      if ( my $splitter = $args{split} ) {
        @data = map { [ split $splitter, $_ ] } @data;
      }
  
      return @data;
    }
  
  
    croak "'split' argument can only be used in list context"
      if $args{split};
  
  
    if ($args{chomped} or $args{chomp}) {
      chomp( my @data = <$fh> );
      return join '', @data;
    }
  
  
    local $/;
    return <$fh>;
  }
  
  sub spew {
      my $self = shift;
      my %args = splice( @_, 0, @_-1 );
  
      my $iomode = $args{iomode} || 'w';
      my $fh = $self->open( $iomode ) or croak "Can't write to $self: $!";
  
      if (ref($_[0]) eq 'ARRAY') {
          # Use old-school for loop to avoid copying.
          for (my $i = 0; $i < @{ $_[0] }; $i++) {
              print $fh $_[0]->[$i];
          }
      }
      else {
          print $fh $_[0];
      }
  
      return;
  }
  
  sub remove {
    my $file = shift->stringify;
    return unlink $file unless -e $file; # Sets $! correctly
    1 while unlink $file;
    return not -e $file;
  }
  
  sub traverse {
    my $self = shift;
    my ($callback, @args) = @_;
    return $self->$callback(sub { () }, @args);
  }
  
  sub traverse_if {
    my $self = shift;
    my ($callback, $condition, @args) = @_;
    return $self->$callback(sub { () }, @args);
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Path::Class::File - Objects representing files
  
  =head1 VERSION
  
  version 0.32
  
  =head1 SYNOPSIS
  
    use Path::Class qw(file);  # Export a short constructor
    
    my $file = file('foo', 'bar.txt');  # Path::Class::File object
    my $file = Path::Class::File->new('foo', 'bar.txt'); # Same thing
    
    # Stringifies to 'foo/bar.txt' on Unix, 'foo\bar.txt' on Windows, etc.
    print "file: $file\n";
    
    if ($file->is_absolute) { ... }
    if ($file->is_relative) { ... }
    
    my $v = $file->volume; # Could be 'C:' on Windows, empty string
                           # on Unix, 'Macintosh HD:' on Mac OS
    
    $file->cleanup; # Perform logical cleanup of pathname
    $file->resolve; # Perform physical cleanup of pathname
    
    my $dir = $file->dir;  # A Path::Class::Dir object
    
    my $abs = $file->absolute; # Transform to absolute path
    my $rel = $file->relative; # Transform to relative path
  
  =head1 DESCRIPTION
  
  The C<Path::Class::File> class contains functionality for manipulating
  file names in a cross-platform way.
  
  =head1 METHODS
  
  =over 4
  
  =item $file = Path::Class::File->new( <dir1>, <dir2>, ..., <file> )
  
  =item $file = file( <dir1>, <dir2>, ..., <file> )
  
  Creates a new C<Path::Class::File> object and returns it.  The
  arguments specify the path to the file.  Any volume may also be
  specified as the first argument, or as part of the first argument.
  You can use platform-neutral syntax:
  
    my $file = file( 'foo', 'bar', 'baz.txt' );
  
  or platform-native syntax:
  
    my $file = file( 'foo/bar/baz.txt' );
  
  or a mixture of the two:
  
    my $file = file( 'foo/bar', 'baz.txt' );
  
  All three of the above examples create relative paths.  To create an
  absolute path, either use the platform native syntax for doing so:
  
    my $file = file( '/var/tmp/foo.txt' );
  
  or use an empty string as the first argument:
  
    my $file = file( '', 'var', 'tmp', 'foo.txt' );
  
  If the second form seems awkward, that's somewhat intentional - paths
  like C</var/tmp> or C<\Windows> aren't cross-platform concepts in the
  first place, so they probably shouldn't appear in your code if you're
  trying to be cross-platform.  The first form is perfectly fine,
  because paths like this may come from config files, user input, or
  whatever.
  
  =item $file->stringify
  
  This method is called internally when a C<Path::Class::File> object is
  used in a string context, so the following are equivalent:
  
    $string = $file->stringify;
    $string = "$file";
  
  =item $file->volume
  
  Returns the volume (e.g. C<C:> on Windows, C<Macintosh HD:> on Mac OS,
  etc.) of the object, if any.  Otherwise, returns the empty string.
  
  =item $file->basename
  
  Returns the name of the file as a string, without the directory
  portion (if any).
  
  =item $file->components
  
  Returns a list of the directory components of this file, followed by
  the basename.
  
  Note: unlike C<< $dir->components >>, this method currently does not
  accept any arguments to select which elements of the list will be
  returned.  It may do so in the future.  Currently it throws an
  exception if such arguments are present.
  
  
  =item $file->is_dir
  
  Returns a boolean value indicating whether this object represents a
  directory.  Not surprisingly, C<Path::Class::File> objects always
  return false, and L<Path::Class::Dir> objects always return true.
  
  =item $file->is_absolute
  
  Returns true or false depending on whether the file refers to an
  absolute path specifier (like C</usr/local/foo.txt> or C<\Windows\Foo.txt>).
  
  =item $file->is_relative
  
  Returns true or false depending on whether the file refers to a
  relative path specifier (like C<lib/foo.txt> or C<.\Foo.txt>).
  
  =item $file->cleanup
  
  Performs a logical cleanup of the file path.  For instance:
  
    my $file = file('/foo//baz/./foo.txt')->cleanup;
    # $file now represents '/foo/baz/foo.txt';
  
  =item $dir->resolve
  
  Performs a physical cleanup of the file path.  For instance:
  
    my $file = file('/foo/baz/../foo.txt')->resolve;
    # $file now represents '/foo/foo.txt', assuming no symlinks
  
  This actually consults the filesystem to verify the validity of the
  path.
  
  =item $dir = $file->dir
  
  Returns a C<Path::Class::Dir> object representing the directory
  containing this file.
  
  =item $dir = $file->parent
  
  A synonym for the C<dir()> method.
  
  =item $abs = $file->absolute
  
  Returns a C<Path::Class::File> object representing C<$file> as an
  absolute path.  An optional argument, given as either a string or a
  L<Path::Class::Dir> object, specifies the directory to use as the base
  of relativity - otherwise the current working directory will be used.
  
  =item $rel = $file->relative
  
  Returns a C<Path::Class::File> object representing C<$file> as a
  relative path.  An optional argument, given as either a string or a
  C<Path::Class::Dir> object, specifies the directory to use as the base
  of relativity - otherwise the current working directory will be used.
  
  =item $foreign = $file->as_foreign($type)
  
  Returns a C<Path::Class::File> object representing C<$file> as it would
  be specified on a system of type C<$type>.  Known types include
  C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
  there is a subclass of C<File::Spec>.
  
  Any generated objects (subdirectories, files, parents, etc.) will also
  retain this type.
  
  =item $foreign = Path::Class::File->new_foreign($type, @args)
  
  Returns a C<Path::Class::File> object representing a file as it would
  be specified on a system of type C<$type>.  Known types include
  C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
  there is a subclass of C<File::Spec>.
  
  The arguments in C<@args> are the same as they would be specified in
  C<new()>.
  
  =item $fh = $file->open($mode, $permissions)
  
  Passes the given arguments, including C<$file>, to C<< IO::File->new >>
  (which in turn calls C<< IO::File->open >> and returns the result
  as an L<IO::File> object.  If the opening
  fails, C<undef> is returned and C<$!> is set.
  
  =item $fh = $file->openr()
  
  A shortcut for
  
   $fh = $file->open('r') or croak "Can't read $file: $!";
  
  =item $fh = $file->openw()
  
  A shortcut for
  
   $fh = $file->open('w') or croak "Can't write to $file: $!";
  
  =item $fh = $file->opena()
  
  A shortcut for
  
   $fh = $file->open('a') or croak "Can't append to $file: $!";
  
  =item $file->touch
  
  Sets the modification and access time of the given file to right now,
  if the file exists.  If it doesn't exist, C<touch()> will I<make> it
  exist, and - YES! - set its modification and access time to now.
  
  =item $file->slurp()
  
  In a scalar context, returns the contents of C<$file> in a string.  In
  a list context, returns the lines of C<$file> (according to how C<$/>
  is set) as a list.  If the file can't be read, this method will throw
  an exception.
  
  If you want C<chomp()> run on each line of the file, pass a true value
  for the C<chomp> or C<chomped> parameters:
  
    my @lines = $file->slurp(chomp => 1);
  
  You may also use the C<iomode> parameter to pass in an IO mode to use
  when opening the file, usually IO layers (though anything accepted by
  the MODE argument of C<open()> is accepted here).  Just make sure it's
  a I<reading> mode.
  
    my @lines = $file->slurp(iomode => ':crlf');
    my $lines = $file->slurp(iomode => '<:encoding(UTF-8)');
  
  The default C<iomode> is C<r>.
  
  Lines can also be automatically splitted, mimicking the perl command-line
  option C<-a> by using the C<split> parameter. If this parameter is used,
  each line will be returned as an array ref.
  
      my @lines = $file->slurp( chomp => 1, split => qr/\s*,\s*/ );
  
  The C<split> parameter can only be used in a list context.
  
  =item $file->spew( $content );
  
  The opposite of L</slurp>, this takes a list of strings and prints them
  to the file in write mode.  If the file can't be written to, this method
  will throw an exception.
  
  The content to be written can be either an array ref or a plain scalar.
  If the content is an array ref then each entry in the array will be
  written to the file.
  
  You may use the C<iomode> parameter to pass in an IO mode to use when
  opening the file, just like L</slurp> supports.
  
    $file->spew(iomode => '>:raw', $content);
  
  The default C<iomode> is C<w>.
  
  =item $file->traverse(sub { ... }, @args)
  
  Calls the given callback on $file. This doesn't do much on its own,
  but see the associated documentation in L<Path::Class::Dir>.
  
  =item $file->remove()
  
  This method will remove the file in a way that works well on all
  platforms, and returns a boolean value indicating whether or not the
  file was successfully removed.  
  
  C<remove()> is better than simply calling Perl's C<unlink()> function,
  because on some platforms (notably VMS) you actually may need to call
  C<unlink()> several times before all versions of the file are gone -
  the C<remove()> method handles this process for you.
  
  =item $st = $file->stat()
  
  Invokes C<< File::stat::stat() >> on this file and returns a
  L<File::stat> object representing the result.
  
  =item $st = $file->lstat()
  
  Same as C<stat()>, but if C<$file> is a symbolic link, C<lstat()>
  stats the link instead of the file the link points to.
  
  =item $class = $file->dir_class()
  
  Returns the class which should be used to create directory objects.
  
  Generally overridden whenever this class is subclassed.
  
  =back
  
  =head1 AUTHOR
  
  Ken Williams, kwilliams@cpan.org
  
  =head1 SEE ALSO
  
  L<Path::Class>, L<Path::Class::Dir>, L<File::Spec>
  
  =cut
PATH_CLASS_FILE

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

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

$fatpacked{"Sub/Quote.pm"} = <<'SUB_QUOTE';
  package Sub::Quote;
  
  use strictures 1;
  
  sub _clean_eval { eval $_[0] }
  
  use Sub::Defer;
  use B 'perlstring';
  use Scalar::Util qw(weaken);
  use base qw(Exporter);
  
  our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub);
  
  our %QUOTED;
  
  our %WEAK_REFS;
  
  sub capture_unroll {
    my ($from, $captures, $indent) = @_;
    join(
      '',
      map {
        /^([\@\%\$])/
          or die "capture key should start with \@, \% or \$: $_";
        (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
      } keys %$captures
    );
  }
  
  sub inlinify {
    my ($code, $args, $extra, $local) = @_;
    my $do = 'do { '.($extra||'');
    if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) {
      if ($code_args eq $args) {
        $do.$body.' }'
      } else {
        $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }';
      }
    } else {
      my $assign = '';
      if ($local || $args ne '@_') {
        $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); ';
      }
      $do.$assign.$code.' }';
    }
  }
  
  sub quote_sub {
    # HOLY DWIMMERY, BATMAN!
    # $name => $code => \%captures => \%options
    # $name => $code => \%captures
    # $name => $code
    # $code => \%captures => \%options
    # $code
    my $options =
      (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
        ? pop
        : {};
    my $captures = pop if ref($_[-1]) eq 'HASH';
    undef($captures) if $captures && !keys %$captures;
    my $code = pop;
    my $name = $_[0];
    my $outstanding;
    my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
      unquote_sub($outstanding);
    };
    $outstanding = "$deferred";
    $QUOTED{$outstanding} = [ $name, $code, $captures ];
    weaken($WEAK_REFS{$outstanding} = $deferred);
    return $deferred;
  }
  
  sub quoted_from_sub {
    my ($sub) = @_;
    $WEAK_REFS{$sub||''} and $QUOTED{$sub||''};
  }
  
  sub unquote_sub {
    my ($sub) = @_;
    unless ($QUOTED{$sub}[3]) {
      my ($name, $code, $captures) = @{$QUOTED{$sub}};
  
      my $make_sub = "{\n";
  
      if (keys %$captures) {
        $make_sub .= capture_unroll("\$_[1]", $captures, 2);
      }
  
      my $o_quoted = perlstring $sub;
      $make_sub .= (
        $name
            # disable the 'variable $x will not stay shared' warning since
            # we're not letting it escape from this scope anyway so there's
            # nothing trying to share it
          ? "  no warnings 'closure';\n  sub ${name} {\n"
          : "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n"
      );
      $make_sub .= $code;
      $make_sub .= "  }".($name ? '' : ';')."\n";
      if ($name) {
        $make_sub .= "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n";
      }
      $make_sub .= "}\n1;\n";
      $ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
      {
        local $@;
        no strict 'refs';
        local *{$name} if $name;
        unless (_clean_eval $make_sub, $captures) {
          die "Eval went very, very wrong:\n\n${make_sub}\n\n$@";
        }
      }
    }
    $QUOTED{$sub}[3];
  }
  
  1;
  
  =head1 NAME
  
  Sub::Quote - efficient generation of subroutines via string eval
  
  =head1 SYNOPSIS
  
   package Silly;
  
   use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
  
   quote_sub 'Silly::kitty', q{ print "meow" };
  
   quote_sub 'Silly::doggy', q{ print "woof" };
  
   my $sound = 0;
  
   quote_sub 'Silly::dagron',
     q{ print ++$sound % 2 ? 'burninate' : 'roar' },
     { '$sound' => \$sound };
  
  And elsewhere:
  
   Silly->kitty;  # meow
   Silly->doggy;  # woof
   Silly->dagron; # burninate
   Silly->dagron; # roar
   Silly->dagron; # burninate
  
  =head1 DESCRIPTION
  
  This package provides performant ways to generate subroutines from strings.
  
  =head1 SUBROUTINES
  
  =head2 quote_sub
  
   my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
  
  Arguments: ?$name, $code, ?\%captures, ?\%options
  
  C<$name> is the subroutine where the coderef will be installed.
  
  C<$code> is a string that will be turned into code.
  
  C<\%captures> is a hashref of variables that will be made available to the
  code.  See the L</SYNOPSIS>'s C<Silly::dagron> for an example using captures.
  
  =head3 options
  
  =over 2
  
  =item * no_install
  
  B<Boolean>.  Set this option to not install the generated coderef into the
  passed subroutine name on undefer.
  
  =back
  
  =head2 unquote_sub
  
   my $coderef = unquote_sub $sub;
  
  Forcibly replace subroutine with actual code.
  
  If $sub is not a quoted sub, this is a no-op.
  
  =head2 quoted_from_sub
  
   my $data = quoted_from_sub $sub;
  
   my ($name, $code, $captures, $compiled_sub) = @$data;
  
  Returns original arguments to quote_sub, plus the compiled version if this
  sub has already been unquoted.
  
  Note that $sub can be either the original quoted version or the compiled
  version for convenience.
  
  =head2 inlinify
  
   my $prelude = capture_unroll '$captures', {
     '$x' => 1,
     '$y' => 2,
   };
  
   my $inlined_code = inlinify q{
     my ($x, $y) = @_;
  
     print $x + $y . "\n";
   }, '$x, $y', $prelude;
  
  Takes a string of code, a string of arguments, a string of code which acts as a
  "prelude", and a B<Boolean> representing whether or not to localize the
  arguments.
  
  =head2 capture_unroll
  
   my $prelude = capture_unroll '$captures', {
     '$x' => 1,
     '$y' => 2,
   }, 4;
  
  Arguments: $from, \%captures, $indent
  
  Generates a snippet of code which is suitable to be used as a prelude for
  L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
  code.  The keys of C<%captures> are the names of the variables and the values
  are ignored.  C<$indent> is the number of spaces to indent the result by.
  
  =head1 CAVEATS
  
  Much of this is just string-based code-generation, and as a result, a few caveats
  apply.
  
  =head2 return
  
  Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
  Instead of returning from the code you defined in C<quote_sub>, it will return
  from the overall function it is composited into.
  
  So when you pass in:
  
     quote_sub q{  return 1 if $condition; $morecode }
  
  It might turn up in the intended context as follows:
  
    sub foo {
  
      <important code a>
      do {
        return 1 if $condition;
        $morecode
      };
      <important code b>
  
    }
  
  Which will obviously return from foo, when all you meant to do was return from
  the code context in quote_sub and proceed with running important code b.
  
  =head2 strictures
  
  Sub::Quote compiles quoted subs in an environment where C<< use strictures >>
  is in effect. L<strictures> enables L<strict> and FATAL L<warnings>.
  
  The following dies I<< Use of uninitialized value in print... >>
  
   no warnings;
   quote_sub 'Silly::kitty', q{ print undef };
  
  If you need to disable parts of strictures, do it within the quoted sub:
  
   quote_sub 'Silly::kitty', q{ no warnings; print undef };
  
  =head1 SUPPORT
  
  See L<Moo> for support and contact information.
  
  =head1 AUTHORS
  
  See L<Moo> for authors.
  
  =head1 COPYRIGHT AND LICENSE
  
  See L<Moo> for the copyright and license.
SUB_QUOTE

$fatpacked{"Try/Tiny.pm"} = <<'TRY_TINY';
  package Try::Tiny;
  BEGIN {
    $Try::Tiny::AUTHORITY = 'cpan:NUFFIN';
  }
  {
    $Try::Tiny::VERSION = '0.16';
  }
  use 5.006;
  # ABSTRACT: minimal try/catch with proper preservation of $@
  
  use strict;
  use warnings;
  
  use base 'Exporter';
  our @EXPORT = our @EXPORT_OK = qw(try catch finally);
  
  use Carp;
  $Carp::Internal{+__PACKAGE__}++;
  
  BEGIN { eval "use Sub::Name; 1" or *{subname} = sub {1} }
  
  # 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;
  
    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
    my $caller = caller;
    subname("${caller}::try {...} " => $try);
    subname("${caller}::catch {...} " => $catch) if $catch;
    subname("${caller}::finally {...} " => $_) foreach @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 $fail to false
    };
  
    # preserve the current error and reset the original value of $@
    $error = $@;
    $@ = $prev_error;
  
    # set up a scope guard to invoke the finally block at the end
    my @guards =
      map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
      @finally;
  
    # at this point $failed contains a true value if the eval died, even if some
    # destructor overwrote $@ as the eval was unwinding.
    if ( $failed ) {
      # 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;
  
    return (
      bless(\$block, 'Try::Tiny::Catch'),
      @rest,
    );
  }
  
  sub finally (&;@) {
    my ( $block, @rest ) = @_;
  
    croak 'Useless bare finally()' unless wantarray;
  
    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
  
  =head1 NAME
  
  Try::Tiny - minimal try/catch with proper preservation of $@
  
  =head1 VERSION
  
  version 0.16
  
  =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.
  
  =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, C<$@> is clobbered at the beginning of the C<eval>, which
  also makes 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 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 SHINY SYNTAX
  
  Using Perl 5.10 you can use L<perlsyn/"Switch statements">.
  
  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
  arglist. 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!";
    }
  
  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.
  
  =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 unhygenically 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<considired 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<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 VERSION CONTROL
  
  L<http://github.com/doy/try-tiny/>
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Yuval Kogman <nothingmuch@woobling.org>
  
  =item *
  
  Jesse Luehrs <doy@tozt.net>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2013 by Yuval Kogman.
  
  This is free software, licensed under:
  
    The MIT (X11) License
  
  =cut
TRY_TINY

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

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

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

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

$fatpacked{"URI/Split.pm"} = <<'URI_SPLIT';
  package URI::Split;
  
  use strict;
  
  use vars qw(@ISA @EXPORT_OK);
  require Exporter;
  @ISA = qw(Exporter);
  @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"} = <<'URI_URL';
  package URI::URL;
  
  require URI::WithBase;
  @ISA=qw(URI::WithBase);
  
  use strict;
  use vars qw(@EXPORT $VERSION);
  
  $VERSION = "5.04";
  
  # Provide as much as possible of the old URI::URL interface for backwards
  # compatibility...
  
  require Exporter;
  *import = \&Exporter::import;
  @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 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 loosing
  	# 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"} = <<'URI_WITHBASE';
  package URI::WithBase;
  
  use strict;
  use vars qw($AUTOLOAD $VERSION);
  use URI;
  
  $VERSION = "2.20";
  
  use overload '""' => "as_string", fallback => 1;
  
  sub as_string;  # help overload find it
  
  sub new
  {
      my($class, $uri, $base) = @_;
      my $ibase = $base;
      if ($base && ref($base) && UNIVERSAL::isa($base, __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 UNIVERSAL::isa($other, __PACKAGE__);
      $self->[0]->eq($other);
  }
  
  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"} = <<'URI__FOREIGN';
  package URI::_foreign;
  
  require URI::_generic;
  @ISA=qw(URI::_generic);
  
  1;
URI__FOREIGN

$fatpacked{"URI/_generic.pm"} = <<'URI__GENERIC';
  package URI::_generic;
  require URI;
  require URI::_query;
  @ISA=qw(URI URI::_query);
  
  use strict;
  use URI::Escape qw(uri_unescape);
  use Carp ();
  
  my $ACHAR = $URI::uric;  $ACHAR =~ s,\\[/?],,g;
  my $PCHAR = $URI::uric;  $PCHAR =~ s,\\[?],,g;
  
  sub _no_scheme_ok { 1 }
  
  sub authority
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
  
      if (@_) {
  	my $auth = shift;
  	$$self = $1;
  	my $rest = $3;
  	if (defined $auth) {
  	    $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
  	    utf8::downgrade($auth);
  	    $$self .= "//$auth";
  	}
  	_check_path($rest, $$self);
  	$$self .= $rest;
      }
      $2;
  }
  
  sub path
  {
      my $self = shift;
      $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
  
      if (@_) {
  	$$self = $1;
  	my $rest = $3;
  	my $new_path = shift;
  	$new_path = "" unless defined $new_path;
  	$new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
  	utf8::downgrade($new_path);
  	_check_path($new_path, $$self);
  	$$self .= $new_path . $rest;
      }
      $2;
  }
  
  sub path_query
  {
      my $self = shift;
      $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
  
      if (@_) {
  	$$self = $1;
  	my $rest = $3;
  	my $new_path = shift;
  	$new_path = "" unless defined $new_path;
  	$new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
  	utf8::downgrade($new_path);
  	_check_path($new_path, $$self);
  	$$self .= $new_path . $rest;
      }
      $2;
  }
  
  sub _check_path
  {
      my($path, $pre) = @_;
      my $prefix;
      if ($pre =~ m,/,) {  # authority present
  	$prefix = "/" if length($path) && $path !~ m,^[/?\#],;
      }
      else {
  	if ($path =~ m,^//,) {
  	    Carp::carp("Path starting with double slash is confusing")
  		if $^W;
  	}
  	elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
  	    Carp::carp("Path might look like scheme, './' prepended")
  		if $^W;
  	    $prefix = "./";
  	}
      }
      substr($_[0], 0, 0) = $prefix if defined $prefix;
  }
  
  sub path_segments
  {
      my $self = shift;
      my $path = $self->path;
      if (@_) {
  	my @arg = @_;  # make a copy
  	for (@arg) {
  	    if (ref($_)) {
  		my @seg = @$_;
  		$seg[0] =~ s/%/%25/g;
  		for (@seg) { s/;/%3B/g; }
  		$_ = join(";", @seg);
  	    }
  	    else {
  		 s/%/%25/g; s/;/%3B/g;
  	    }
  	    s,/,%2F,g;
  	}
  	$self->path(join("/", @arg));
      }
      return $path unless wantarray;
      map {/;/ ? $self->_split_segment($_)
               : uri_unescape($_) }
          split('/', $path, -1);
  }
  
  
  sub _split_segment
  {
      my $self = shift;
      require URI::_segment;
      URI::_segment->new(@_);
  }
  
  
  sub abs
  {
      my $self = shift;
      my $base = shift || Carp::croak("Missing base argument");
  
      if (my $scheme = $self->scheme) {
  	return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
  	$base = URI->new($base) unless ref $base;
  	return $self unless $scheme eq $base->scheme;
      }
  
      $base = URI->new($base) unless ref $base;
      my $abs = $self->clone;
      $abs->scheme($base->scheme);
      return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
      $abs->authority($base->authority);
  
      my $path = $self->path;
      return $abs if $path =~ m,^/,;
  
      if (!length($path)) {
  	my $abs = $base->clone;
  	my $query = $self->query;
  	$abs->query($query) if defined $query;
  	$abs->fragment($self->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"} = <<'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 URI::_punycode qw(encode_punycode decode_punycode);
  use Carp qw(croak);
  
  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"} = <<'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 vars qw($VERSION);
  $VERSION = "1.12";
  
  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 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 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"} = <<'URI__LOGIN';
  package URI::_login;
  
  require URI::_server;
  require URI::_userpass;
  @ISA = qw(URI::_server URI::_userpass);
  
  # Generic terminal logins.  This is used as a base class for 'telnet',
  # 'tn3270', and 'rlogin' URL schemes.
  
  1;
URI__LOGIN

$fatpacked{"URI/_punycode.pm"} = <<'URI__PUNYCODE';
  package URI::_punycode;
  
  use strict;
  our $VERSION = "0.04";
  
  require Exporter;
  our @ISA    = qw(Exporter);
  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__
  
  =head1 NAME
  
  URI::_punycode - encodes Unicode string in Punycode
  
  =head1 SYNOPSIS
  
    use URI::_punycode;
    $punycode = encode_punycode($unicode);
    $unicode  = decode_punycode($punycode);
  
  =head1 DESCRIPTION
  
  URI::_punycode is a module to encode / decode Unicode strings into
  Punycode, an efficient encoding of Unicode for use with IDNA.
  
  This module requires Perl 5.6.0 or over to handle UTF8 flagged Unicode
  strings.
  
  =head1 FUNCTIONS
  
  This module exports following functions by default.
  
  =over 4
  
  =item encode_punycode
  
    $punycode = encode_punycode($unicode);
  
  takes Unicode string (UTF8-flagged variable) and returns Punycode
  encoding for it.
  
  =item decode_punycode
  
    $unicode = decode_punycode($punycode)
  
  takes Punycode encoding and returns original Unicode string.
  
  =back
  
  These functions throw exceptions on failure. You can catch 'em via
  C<eval>.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> is the author of
  IDNA::Punycode v0.02 which was the basis for this module.
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<IDNA::Punycode>, RFC 3492
  
  =cut
URI__PUNYCODE

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

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

$fatpacked{"URI/_userpass.pm"} = <<'URI__USERPASS';
  package URI::_userpass;
  
  use strict;
  use URI::Escape qw(uri_unescape);
  
  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 unless defined $info;
      $info =~ s/:.*//;
      uri_unescape($info);
  }
  
  sub password
  {
      my $self = shift;
      my $info = $self->userinfo;
      if (@_) {
  	my $new = shift;
  	my $user = defined($info) ? $info : "";
  	$user =~ s/:.*//;
  
  	if (!defined($new) && !length($user)) {
  	    $self->userinfo(undef);
  	} else {
  	    $new = "" unless defined($new);
  	    $new =~ s/%/%25/g;
  	    $self->userinfo("$user:$new");
  	}
      }
      return unless defined $info;
      return unless $info =~ s/^[^:]*://;
      uri_unescape($info);
  }
  
  1;
URI__USERPASS

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

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

$fatpacked{"URI/file/Base.pm"} = <<'URI_FILE_BASE';
  package URI::file::Base;
  
  use strict;
  use URI::Escape qw();
  
  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"} = <<'URI_FILE_FAT';
  package URI::file::FAT;
  
  require URI::file::Win32;
  @ISA=qw(URI::file::Win32);
  
  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"} = <<'URI_FILE_MAC';
  package URI::file::Mac;
  
  require URI::file::Base;
  @ISA=qw(URI::file::Base);
  
  use strict;
  use URI::Escape qw(uri_unescape);
  
  
  
  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"} = <<'URI_FILE_OS2';
  package URI::file::OS2;
  
  require URI::file::Win32;
  @ISA=qw(URI::file::Win32);
  
  # 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"} = <<'URI_FILE_QNX';
  package URI::file::QNX;
  
  require URI::file::Unix;
  @ISA=qw(URI::file::Unix);
  
  use strict;
  
  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"} = <<'URI_FILE_UNIX';
  package URI::file::Unix;
  
  require URI::file::Base;
  @ISA=qw(URI::file::Base);
  
  use strict;
  use URI::Escape qw(uri_unescape);
  
  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"} = <<'URI_FILE_WIN32';
  package URI::file::Win32;
  
  require URI::file::Base;
  @ISA=qw(URI::file::Base);
  
  use strict;
  use URI::Escape qw(uri_unescape);
  
  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"} = <<'URI_FTP';
  package URI::ftp;
  
  require URI::_server;
  require URI::_userpass;
  @ISA=qw(URI::_server URI::_userpass);
  
  use strict;
  
  sub default_port { 21 }
  
  sub path { shift->path_query(@_) }  # XXX
  
  sub _user     { shift->SUPER::user(@_);     }
  sub _password { shift->SUPER::password(@_); }
  
  sub user
  {
      my $self = shift;
      my $user = $self->_user(@_);
      $user = "anonymous" unless defined $user;
      $user;
  }
  
  sub password
  {
      my $self = shift;
      my $pass = $self->_password(@_);
      unless (defined $pass) {
  	my $user = $self->user;
  	if ($user eq 'anonymous' || $user eq 'ftp') {
  	    # anonymous ftp login password
              # If there is no ftp anonymous password specified
              # then we'll just use 'anonymous@'
              # We don't try to send the read e-mail address because:
              # - We want to remain anonymous
              # - We want to stop SPAM
              # - We don't want to let ftp sites to discriminate by the user,
              #   host, country or ftp client being used.
  	    $pass = 'anonymous@';
  	}
      }
      $pass;
  }
  
  1;
URI_FTP

$fatpacked{"URI/gopher.pm"} = <<'URI_GOPHER';
  package URI::gopher;  # <draft-murali-url-gopher>, Dec 4, 1996
  
  require URI::_server;
  @ISA=qw(URI::_server);
  
  use strict;
  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;
  }
  
  *gtype = \&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"} = <<'URI_HTTP';
  package URI::http;
  
  require URI::_server;
  @ISA=qw(URI::_server);
  
  use strict;
  
  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"} = <<'URI_HTTPS';
  package URI::https;
  require URI::http;
  @ISA=qw(URI::http);
  
  sub default_port { 443 }
  
  sub secure { 1 }
  
  1;
URI_HTTPS

$fatpacked{"URI/ldap.pm"} = <<'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 vars qw(@ISA $VERSION);
  $VERSION = "1.12";
  
  require URI::_server;
  require URI::_ldap;
  @ISA=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"} = <<'URI_LDAPI';
  package URI::ldapi;
  
  use strict;
  
  use vars qw(@ISA);
  
  require URI::_generic;
  require URI::_ldap;
  @ISA=qw(URI::_ldap URI::_generic);
  
  require URI::Escape;
  
  sub un_path {
      my $self = shift;
      my $old = URI::Escape::uri_unescape($self->authority);
      if (@_) {
  	my $p = shift;
  	$p =~ s/:/%3A/g;
  	$p =~ s/\@/%40/g;
  	$self->authority($p);
      }
      return $old;
  }
  
  sub _nonldap_canonical {
      my $self = shift;
      $self->URI::_generic::canonical(@_);
  }
  
  1;
URI_LDAPI

$fatpacked{"URI/ldaps.pm"} = <<'URI_LDAPS';
  package URI::ldaps;
  require URI::ldap;
  @ISA=qw(URI::ldap);
  
  sub default_port { 636 }
  
  sub secure { 1 }
  
  1;
URI_LDAPS

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

$fatpacked{"URI/mms.pm"} = <<'URI_MMS';
  package URI::mms;
  
  require URI::http;
  @ISA=qw(URI::http);
  
  sub default_port { 1755 }
  
  1;
URI_MMS

$fatpacked{"URI/news.pm"} = <<'URI_NEWS';
  package URI::news;  # draft-gilman-news-url-01
  
  require URI::_server;
  @ISA=qw(URI::_server);
  
  use strict;
  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 unless $old =~ /\@/;
      return $old;
  }
  
  1;
URI_NEWS

$fatpacked{"URI/nntp.pm"} = <<'URI_NNTP';
  package URI::nntp;  # draft-gilman-news-url-01
  
  require URI::news;
  @ISA=qw(URI::news);
  
  1;
URI_NNTP

$fatpacked{"URI/pop.pm"} = <<'URI_POP';
  package URI::pop;   # RFC 2384
  
  require URI::_server;
  @ISA=qw(URI::_server);
  
  use strict;
  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 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 unless defined $old;
      $old =~ s/^[^;]*//;
      return uri_unescape($1) if $old =~ /;auth=(.*)/i;
      return;
  }
  
  1;
URI_POP

$fatpacked{"URI/rlogin.pm"} = <<'URI_RLOGIN';
  package URI::rlogin;
  require URI::_login;
  @ISA = qw(URI::_login);
  
  sub default_port { 513 }
  
  1;
URI_RLOGIN

$fatpacked{"URI/rsync.pm"} = <<'URI_RSYNC';
  package URI::rsync;  # http://rsync.samba.org/
  
  # rsync://[USER@]HOST[:PORT]/SRC
  
  require URI::_server;
  require URI::_userpass;
  
  @ISA=qw(URI::_server URI::_userpass);
  
  sub default_port { 873 }
  
  1;
URI_RSYNC

$fatpacked{"URI/rtsp.pm"} = <<'URI_RTSP';
  package URI::rtsp;
  
  require URI::http;
  @ISA=qw(URI::http);
  
  sub default_port { 554 }
  
  1;
URI_RTSP

$fatpacked{"URI/rtspu.pm"} = <<'URI_RTSPU';
  package URI::rtspu;
  
  require URI::rtsp;
  @ISA=qw(URI::rtsp);
  
  sub default_port { 554 }
  
  1;
URI_RTSPU

$fatpacked{"URI/sip.pm"} = <<'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;
  
  require URI::_server;
  require URI::_userpass;
  @ISA=qw(URI::_server URI::_userpass);
  
  use strict;
  use vars qw(@ISA $VERSION);
  use URI::Escape qw(uri_unescape);
  
  $VERSION = "0.11";
  
  sub default_port { 5060 }
  
  sub authority
  {
      my $self = shift;
      $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
      my $old = $2;
  
      if (@_) {
          my $auth = shift;
          $$self = defined($1) ? $1 : "";
          my $rest = $3;
          if (defined $auth) {
              $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
              $$self .= "$auth";
          }
          $$self .= $rest;
      }
      $old;
  }
  
  sub params_form
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
      my $paramstr = $3;
  
      if (@_) {
      	my @args = @_; 
          $$self = $1 . $2;
          my $rest = $4;
  	my @new;
  	for (my $i=0; $i < @args; $i += 2) {
  	    push(@new, "$args[$i]=$args[$i+1]");
  	}
  	$paramstr = join(";", @new);
  	$$self .= ";" . $paramstr . $rest;
      }
      $paramstr =~ s/^;//o;
      return split(/[;=]/, $paramstr);
  }
  
  sub params
  {
      my $self = shift;
      $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
      my $paramstr = $3;
  
      if (@_) {
      	my $new = shift; 
          $$self = $1 . $2;
          my $rest = $4;
  	$$self .= $paramstr . $rest;
      }
      $paramstr =~ s/^;//o;
      return $paramstr;
  }
  
  # Inherited methods that make no sense for a SIP URI.
  sub path {}
  sub path_query {}
  sub path_segments {}
  sub abs { shift }
  sub rel { shift }
  sub query_keywords {}
  
  1;
URI_SIP

$fatpacked{"URI/sips.pm"} = <<'URI_SIPS';
  package URI::sips;
  require URI::sip;
  @ISA=qw(URI::sip);
  
  sub default_port { 5061 }
  
  sub secure { 1 }
  
  1;
URI_SIPS

$fatpacked{"URI/snews.pm"} = <<'URI_SNEWS';
  package URI::snews;  # draft-gilman-news-url-01
  
  require URI::news;
  @ISA=qw(URI::news);
  
  sub default_port { 563 }
  
  sub secure { 1 }
  
  1;
URI_SNEWS

$fatpacked{"URI/ssh.pm"} = <<'URI_SSH';
  package URI::ssh;
  require URI::_login;
  @ISA=qw(URI::_login);
  
  # ssh://[USER@]HOST[:PORT]/SRC
  
  sub default_port { 22 }
  
  sub secure { 1 }
  
  1;
URI_SSH

$fatpacked{"URI/telnet.pm"} = <<'URI_TELNET';
  package URI::telnet;
  require URI::_login;
  @ISA = qw(URI::_login);
  
  sub default_port { 23 }
  
  1;
URI_TELNET

$fatpacked{"URI/tn3270.pm"} = <<'URI_TN3270';
  package URI::tn3270;
  require URI::_login;
  @ISA = qw(URI::_login);
  
  sub default_port { 23 }
  
  1;
URI_TN3270

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

$fatpacked{"URI/urn/oid.pm"} = <<'URI_URN_OID';
  package URI::urn::oid;  # RFC 2061
  
  require URI::urn;
  @ISA=qw(URI::urn);
  
  use strict;
  
  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{"autodie.pm"} = <<'AUTODIE';
  package autodie;
  use 5.008;
  use strict;
  use warnings;
  
  use Fatal ();
  our @ISA = qw(Fatal);
  our $VERSION;
  
  # ABSTRACT: Replace functions with ones that succeed or die with lexical scope
  
  BEGIN {
      our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg::Version
  }
  
  use constant ERROR_WRONG_FATAL => q{
  Incorrect version of Fatal.pm loaded by autodie.
  
  The autodie pragma uses an updated version of Fatal to do its
  heavy lifting.  We seem to have loaded Fatal version %s, which is
  probably the version that came with your version of Perl.  However
  autodie needs version %s, which would have come bundled with
  autodie.
  
  You may be able to solve this problem by adding the following
  line of code to your main program, before any use of Fatal or
  autodie.
  
      use lib "%s";
  
  };
  
  # We have to check we've got the right version of Fatal before we
  # try to compile the rest of our code, lest we use a constant
  # that doesn't exist.
  
  BEGIN {
  
      # If we have the wrong Fatal, then we've probably loaded the system
      # one, not our own.  Complain, and give a useful hint. ;)
  
      if ($Fatal::VERSION ne $VERSION) {
          my $autodie_path = $INC{'autodie.pm'};
  
          $autodie_path =~ s/autodie\.pm//;
  
          require Carp;
  
          Carp::croak sprintf(
              ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path
          );
      }
  }
  
  # When passing args to Fatal we want to keep the first arg
  # (our package) in place.  Hence the splice.
  
  sub import {
          splice(@_,1,0,Fatal::LEXICAL_TAG);
          goto &Fatal::import;
  }
  
  sub unimport {
          splice(@_,1,0,Fatal::LEXICAL_TAG);
          goto &Fatal::unimport;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  autodie - Replace functions with ones that succeed or die with lexical scope
  
  =head1 SYNOPSIS
  
      use autodie;            # Recommended: implies 'use autodie qw(:default)'
  
      use autodie qw(:all);   # Recommended more: defaults and system/exec.
  
      use autodie qw(open close);   # open/close succeed or die
  
      open(my $fh, "<", $filename); # No need to check!
  
      {
          no autodie qw(open);          # open failures won't die
          open(my $fh, "<", $filename); # Could fail silently!
          no autodie;                   # disable all autodies
      }
  
  =head1 DESCRIPTION
  
          bIlujDI' yIchegh()Qo'; yIHegh()!
  
          It is better to die() than to return() in failure.
  
                  -- Klingon programming proverb.
  
  The C<autodie> pragma provides a convenient way to replace functions
  that normally return false on failure with equivalents that throw
  an exception on failure.
  
  The C<autodie> pragma has I<lexical scope>, meaning that functions
  and subroutines altered with C<autodie> will only change their behaviour
  until the end of the enclosing block, file, or C<eval>.
  
  If C<system> is specified as an argument to C<autodie>, then it
  uses L<IPC::System::Simple> to do the heavy lifting.  See the
  description of that module for more information.
  
  =head1 EXCEPTIONS
  
  Exceptions produced by the C<autodie> pragma are members of the
  L<autodie::exception> class.  The preferred way to work with
  these exceptions under Perl 5.10 is as follows:
  
      use feature qw(switch);
  
      eval {
          use autodie;
  
          open(my $fh, '<', $some_file);
  
          my @records = <$fh>;
  
          # Do things with @records...
  
          close($fh);
  
      };
  
      given ($@) {
          when (undef)   { say "No error";                    }
          when ('open')  { say "Error from open";             }
          when (':io')   { say "Non-open, IO error.";         }
          when (':all')  { say "All other autodie errors."    }
          default        { say "Not an autodie error at all." }
      }
  
  Under Perl 5.8, the C<given/when> structure is not available, so the
  following structure may be used:
  
      eval {
          use autodie;
  
          open(my $fh, '<', $some_file);
  
          my @records = <$fh>;
  
          # Do things with @records...
  
          close($fh);
      };
  
      if ($@ and $@->isa('autodie::exception')) {
          if ($@->matches('open')) { print "Error from open\n";   }
          if ($@->matches(':io' )) { print "Non-open, IO error."; }
      } elsif ($@) {
          # A non-autodie exception.
      }
  
  See L<autodie::exception> for further information on interrogating
  exceptions.
  
  =head1 CATEGORIES
  
  Autodie uses a simple set of categories to group together similar
  built-ins.  Requesting a category type (starting with a colon) will
  enable autodie for all built-ins beneath that category.  For example,
  requesting C<:file> will enable autodie for C<close>, C<fcntl>,
  C<fileno>, C<open> and C<sysopen>.
  
  The categories are currently:
  
      :all
          :default
              :io
                  read
                  seek
                  sysread
                  sysseek
                  syswrite
                  :dbm
                      dbmclose
                      dbmopen
                  :file
                      binmode
                      close
                      chmod
                      chown
                      fcntl
                      fileno
                      flock
                      ioctl
                      open
                      sysopen
                      truncate
                  :filesys
                      chdir
                      closedir
                      opendir
                      link
                      mkdir
                      readlink
                      rename
                      rmdir
                      symlink
                      unlink
                  :ipc
                      pipe
                      :msg
                          msgctl
                          msgget
                          msgrcv
                          msgsnd
                      :semaphore
                          semctl
                          semget
                          semop
                      :shm
                          shmctl
                          shmget
                          shmread
                  :socket
                      accept
                      bind
                      connect
                      getsockopt
                      listen
                      recv
                      send
                      setsockopt
                      shutdown
                      socketpair
              :threads
                  fork
          :system
              system
              exec
  
  
  Note that while the above category system is presently a strict
  hierarchy, this should not be assumed.
  
  A plain C<use autodie> implies C<use autodie qw(:default)>.  Note that
  C<system> and C<exec> are not enabled by default.  C<system> requires
  the optional L<IPC::System::Simple> module to be installed, and enabling
  C<system> or C<exec> will invalidate their exotic forms.  See L</BUGS>
  below for more details.
  
  The syntax:
  
      use autodie qw(:1.994);
  
  allows the C<:default> list from a particular version to be used.  This
  provides the convenience of using the default methods, but the surety
  that no behavioral changes will occur if the C<autodie> module is
  upgraded.
  
  C<autodie> can be enabled for all of Perl's built-ins, including
  C<system> and C<exec> with:
  
      use autodie qw(:all);
  
  =head1 FUNCTION SPECIFIC NOTES
  
  =head2 flock
  
  It is not considered an error for C<flock> to return false if it fails
  due to an C<EWOULDBLOCK> (or equivalent) condition.  This means one can
  still use the common convention of testing the return value of
  C<flock> when called with the C<LOCK_NB> option:
  
      use autodie;
  
      if ( flock($fh, LOCK_EX | LOCK_NB) ) {
          # We have a lock
      }
  
  Autodying C<flock> will generate an exception if C<flock> returns
  false with any other error.
  
  =head2 system/exec
  
  The C<system> built-in is considered to have failed in the following
  circumstances:
  
  =over 4
  
  =item *
  
  The command does not start.
  
  =item *
  
  The command is killed by a signal.
  
  =item *
  
  The command returns a non-zero exit value (but see below).
  
  =back
  
  On success, the autodying form of C<system> returns the I<exit value>
  rather than the contents of C<$?>.
  
  Additional allowable exit values can be supplied as an optional first
  argument to autodying C<system>:
  
      system( [ 0, 1, 2 ], $cmd, @args);  # 0,1,2 are good exit values
  
  C<autodie> uses the L<IPC::System::Simple> module to change C<system>.
  See its documentation for further information.
  
  Applying C<autodie> to C<system> or C<exec> causes the exotic
  forms C<system { $cmd } @args > or C<exec { $cmd } @args>
  to be considered a syntax error until the end of the lexical scope.
  If you really need to use the exotic form, you can call C<CORE::system>
  or C<CORE::exec> instead, or use C<no autodie qw(system exec)> before
  calling the exotic form.
  
  =head1 GOTCHAS
  
  Functions called in list context are assumed to have failed if they
  return an empty list, or a list consisting only of a single undef
  element.
  
  =head1 DIAGNOSTICS
  
  =over 4
  
  =item :void cannot be used with lexical scope
  
  The C<:void> option is supported in L<Fatal>, but not
  C<autodie>.  To workaround this, C<autodie> may be explicitly disabled until
  the end of the current block with C<no autodie>.
  To disable autodie for only a single function (eg, open)
  use C<no autodie qw(open)>.
  
  C<autodie> performs no checking of called context to determine whether to throw
  an exception; the explicitness of error handling with C<autodie> is a deliberate
  feature.
  
  =item No user hints defined for %s
  
  You've insisted on hints for user-subroutines, either by pre-pending
  a C<!> to the subroutine name itself, or earlier in the list of arguments
  to C<autodie>.  However the subroutine in question does not have
  any hints available.
  
  =back
  
  See also L<Fatal/DIAGNOSTICS>.
  
  =head1 BUGS
  
  "Used only once" warnings can be generated when C<autodie> or C<Fatal>
  is used with package filehandles (eg, C<FILE>).  Scalar filehandles are
  strongly recommended instead.
  
  When using C<autodie> or C<Fatal> with user subroutines, the
  declaration of those subroutines must appear before the first use of
  C<Fatal> or C<autodie>, or have been exported from a module.
  Attempting to use C<Fatal> or C<autodie> on other user subroutines will
  result in a compile-time error.
  
  Due to a bug in Perl, C<autodie> may "lose" any format which has the
  same name as an autodying built-in or function.
  
  C<autodie> may not work correctly if used inside a file with a
  name that looks like a string eval, such as F<eval (3)>.
  
  =head2 autodie and string eval
  
  Due to the current implementation of C<autodie>, unexpected results
  may be seen when used near or with the string version of eval.
  I<None of these bugs exist when using block eval>.
  
  Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval>
  statements, although it can be explicitly enabled inside a string
  C<eval>.
  
  Under Perl 5.10 only, using a string eval when C<autodie> is in
  effect can cause the autodie behaviour to leak into the surrounding
  scope.  This can be worked around by using a C<no autodie> at the
  end of the scope to explicitly remove autodie's effects, or by
  avoiding the use of string eval.
  
  I<None of these bugs exist when using block eval>.  The use of
  C<autodie> with block eval is considered good practice.
  
  =head2 REPORTING BUGS
  
  Please report bugs via the CPAN Request Tracker at
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie>.
  
  =head1 FEEDBACK
  
  If you find this module useful, please consider rating it on the
  CPAN Ratings service at
  L<http://cpanratings.perl.org/rate?distribution=autodie> .
  
  The module author loves to hear how C<autodie> has made your life
  better (or worse).  Feedback can be sent to
  E<lt>pjf@perltraining.com.auE<gt>.
  
  =head1 AUTHOR
  
  Copyright 2008-2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
  
  =head1 LICENSE
  
  This module is free software.  You may distribute it under the
  same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<Fatal>, L<autodie::exception>, L<autodie::hints>, L<IPC::System::Simple>
  
  I<Perl tips, autodie> at
  L<http://perltraining.com.au/tips/2008-08-20.html>
  
  =head1 ACKNOWLEDGEMENTS
  
  Mark Reed and Roland Giersig -- Klingon translators.
  
  See the F<AUTHORS> file for full credits.  The latest version of this
  file can be found at
  L<https://github.com/pjf/autodie/tree/master/AUTHORS> .
  
  =cut
AUTODIE

$fatpacked{"autodie/exception.pm"} = <<'AUTODIE_EXCEPTION';
  package autodie::exception;
  use 5.008;
  use strict;
  use warnings;
  use Carp qw(croak);
  
  our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg:Version
  # ABSTRACT: Exceptions from autodying functions.
  
  our $DEBUG = 0;
  
  use overload
      q{""} => "stringify"
  ;
  
  # Overload smart-match only if we're using 5.10
  
  use if ($] >= 5.010), overload => '~~'  => "matches";
  
  my $PACKAGE = __PACKAGE__;  # Useful to have a scalar for hash keys.
  
  =head1 NAME
  
  autodie::exception - Exceptions from autodying functions.
  
  =head1 SYNOPSIS
  
      eval {
          use autodie;
  
          open(my $fh, '<', 'some_file.txt');
  
          ...
      };
  
      if (my $E = $@) {
          say "Ooops!  ",$E->caller," had problems: $@";
      }
  
  
  =head1 DESCRIPTION
  
  When an L<autodie> enabled function fails, it generates an
  C<autodie::exception> object.  This can be interrogated to
  determine further information about the error that occurred.
  
  This document is broken into two sections; those methods that
  are most useful to the end-developer, and those methods for
  anyone wishing to subclass or get very familiar with
  C<autodie::exception>.
  
  =head2 Common Methods
  
  These methods are intended to be used in the everyday dealing
  of exceptions.
  
  The following assume that the error has been copied into
  a separate scalar:
  
      if ($E = $@) {
          ...
      }
  
  This is not required, but is recommended in case any code
  is called which may reset or alter C<$@>.
  
  =cut
  
  =head3 args
  
      my $array_ref = $E->args;
  
  Provides a reference to the arguments passed to the subroutine
  that died.
  
  =cut
  
  sub args        { return $_[0]->{$PACKAGE}{args}; }
  
  =head3 function
  
      my $sub = $E->function;
  
  The subroutine (including package) that threw the exception.
  
  =cut
  
  sub function   { return $_[0]->{$PACKAGE}{function};  }
  
  =head3 file
  
      my $file = $E->file;
  
  The file in which the error occurred (eg, C<myscript.pl> or
  C<MyTest.pm>).
  
  =cut
  
  sub file        { return $_[0]->{$PACKAGE}{file};  }
  
  =head3 package
  
      my $package = $E->package;
  
  The package from which the exceptional subroutine was called.
  
  =cut
  
  sub package     { return $_[0]->{$PACKAGE}{package}; }
  
  =head3 caller
  
      my $caller = $E->caller;
  
  The subroutine that I<called> the exceptional code.
  
  =cut
  
  sub caller      { return $_[0]->{$PACKAGE}{caller};  }
  
  =head3 line
  
      my $line = $E->line;
  
  The line in C<< $E->file >> where the exceptional code was called.
  
  =cut
  
  sub line        { return $_[0]->{$PACKAGE}{line};  }
  
  =head3 context
  
      my $context = $E->context;
  
  The context in which the subroutine was called by autodie; usually
  the same as the context in which you called the autodying subroutine.
  This can be 'list', 'scalar', or undefined (unknown).  It will never
  be 'void', as C<autodie> always captures the return value in one way
  or another.
  
  For some core functions that always return a scalar value regardless
  of their context (eg, C<chown>), this may be 'scalar', even if you
  used a list context.
  
  =cut
  
  # TODO: The comments above say this can be undefined. Is that actually
  # the case? (With 'system', perhaps?)
  
  sub context     { return $_[0]->{$PACKAGE}{context} }
  
  =head3 return
  
      my $return_value = $E->return;
  
  The value(s) returned by the failed subroutine.  When the subroutine
  was called in a list context, this will always be a reference to an
  array containing the results.  When the subroutine was called in
  a scalar context, this will be the actual scalar returned.
  
  =cut
  
  sub return      { return $_[0]->{$PACKAGE}{return} }
  
  =head3 errno
  
      my $errno = $E->errno;
  
  The value of C<$!> at the time when the exception occurred.
  
  B<NOTE>: This method will leave the main C<autodie::exception> class
  and become part of a role in the future.  You should only call
  C<errno> for exceptions where C<$!> would reasonably have been
  set on failure.
  
  =cut
  
  # TODO: Make errno part of a role.  It doesn't make sense for
  # everything.
  
  sub errno       { return $_[0]->{$PACKAGE}{errno}; }
  
  =head3 eval_error
  
      my $old_eval_error = $E->eval_error;
  
  The contents of C<$@> immediately after autodie triggered an
  exception.  This may be useful when dealing with modules such
  as L<Text::Balanced> that set (but do not throw) C<$@> on error.
  
  =cut
  
  sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
  
  =head3 matches
  
      if ( $e->matches('open') ) { ... }
  
      if ( $e ~~ 'open' ) { ... }
  
  C<matches> is used to determine whether a
  given exception matches a particular role.  On Perl 5.10,
  using smart-match (C<~~>) with an C<autodie::exception> object
  will use C<matches> underneath.
  
  An exception is considered to match a string if:
  
  =over 4
  
  =item *
  
  For a string not starting with a colon, the string exactly matches the
  package and subroutine that threw the exception.  For example,
  C<MyModule::log>.  If the string does not contain a package name,
  C<CORE::> is assumed.
  
  =item *
  
  For a string that does start with a colon, if the subroutine
  throwing the exception I<does> that behaviour.  For example, the
  C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
  
  See L<autodie/CATEGORIES> for further information.
  
  =back
  
  =cut
  
  {
      my (%cache);
  
      sub matches {
          my ($this, $that) = @_;
  
          # TODO - Handle references
          croak "UNIMPLEMENTED" if ref $that;
  
          my $sub = $this->function;
  
          if ($DEBUG) {
              my $sub2 = $this->function;
              warn "Smart-matching $that against $sub / $sub2\n";
          }
  
          # Direct subname match.
          return 1 if $that eq $sub;
          return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
          return 0 if $that !~ /^:/;
  
          # Cached match / check tags.
          require Fatal;
  
          if (exists $cache{$sub}{$that}) {
              return $cache{$sub}{$that};
          }
  
          # This rather awful looking line checks to see if our sub is in the
          # list of expanded tags, caches it, and returns the result.
  
          return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
      }
  }
  
  # This exists primarily so that child classes can override or
  # augment it if they wish.
  
  sub _expand_tag {
      my ($this, @args) = @_;
  
      return Fatal->_expand_tag(@args);
  }
  
  =head2 Advanced methods
  
  The following methods, while usable from anywhere, are primarily
  intended for developers wishing to subclass C<autodie::exception>,
  write code that registers custom error messages, or otherwise
  work closely with the C<autodie::exception> model.
  
  =cut
  
  # The table below records customer formatters.
  # TODO - Should this be a package var instead?
  # TODO - Should these be in a completely different file, or
  #        perhaps loaded on demand?  Most formatters will never
  #        get used in most programs.
  
  my %formatter_of = (
      'CORE::close'   => \&_format_close,
      'CORE::open'    => \&_format_open,
      'CORE::dbmopen' => \&_format_dbmopen,
      'CORE::flock'   => \&_format_flock,
  );
  
  # TODO: Our tests only check LOCK_EX | LOCK_NB is properly
  # formatted.  Try other combinations and ensure they work
  # correctly.
  
  sub _format_flock {
      my ($this) = @_;
  
      require Fcntl;
  
      my $filehandle = $this->args->[0];
      my $raw_mode   = $this->args->[1];
  
      my $mode_type;
      my $lock_unlock;
  
      if ($raw_mode & Fcntl::LOCK_EX() ) {
          $lock_unlock = "lock";
          $mode_type = "for exclusive access";
      }
      elsif ($raw_mode & Fcntl::LOCK_SH() ) {
          $lock_unlock = "lock";
          $mode_type = "for shared access";
      }
      elsif ($raw_mode & Fcntl::LOCK_UN() ) {
          $lock_unlock = "unlock";
          $mode_type = "";
      }
      else {
          # I've got no idea what they're trying to do.
          $lock_unlock = "lock";
          $mode_type = "with mode $raw_mode";
      }
  
      my $cooked_filehandle;
  
      if ($filehandle and not ref $filehandle) {
  
          # A package filehandle with a name!
  
          $cooked_filehandle = " $filehandle";
      }
      else {
          # Otherwise we have a scalar filehandle.
  
          $cooked_filehandle = '';
  
      }
  
      local $! = $this->errno;
  
      return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
  
  }
  
  # Default formatter for CORE::dbmopen
  sub _format_dbmopen {
      my ($this) = @_;
      my @args   = @{$this->args};
  
      # TODO: Presently, $args flattens out the (usually empty) hash
      # which is passed as the first argument to dbmopen.  This is
      # a bug in our args handling code (taking a reference to it would
      # be better), but for the moment we'll just examine the end of
      # our arguments list for message formatting.
  
      my $mode = $args[-1];
      my $file = $args[-2];
  
      # If we have a mask, then display it in octal, not decimal.
      # We don't do this if it already looks octalish, or doesn't
      # look like a number.
  
      if ($mode =~ /^[^\D0]\d+$/) {
          $mode = sprintf("0%lo", $mode);
      };
  
      local $! = $this->errno;
  
      return "Can't dbmopen(%hash, '$file', $mode): '$!'";
  }
  
  # Default formatter for CORE::close
  
  sub _format_close {
      my ($this) = @_;
      my $close_arg = $this->args->[0];
  
      local $! = $this->errno;
  
      # If we've got an old-style filehandle, mention it.
      if ($close_arg and not ref $close_arg) {
          return "Can't close filehandle '$close_arg': '$!'";
      }
  
      # TODO - This will probably produce an ugly error.  Test and fix.
      return "Can't close($close_arg) filehandle: '$!'";
  
  }
  
  # Default formatter for CORE::open
  
  use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
  
  sub _format_open_with_mode {
      my ($this, $mode, $file, $error) = @_;
  
      my $wordy_mode;
  
      if    ($mode eq '<')  { $wordy_mode = 'reading';   }
      elsif ($mode eq '>')  { $wordy_mode = 'writing';   }
      elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
  
      return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
  
      Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
  
  }
  
  sub _format_open {
      my ($this) = @_;
  
      my @open_args = @{$this->args};
  
      # Use the default formatter for single-arg and many-arg open
      if (@open_args <= 1 or @open_args >= 4) {
          return $this->format_default;
      }
  
      # For two arg open, we have to extract the mode
      if (@open_args == 2) {
          my ($fh, $file) = @open_args;
  
          if (ref($fh) eq "GLOB") {
              $fh = '$fh';
          }
  
          my ($mode) = $file =~ m{
              ^\s*                # Spaces before mode
              (
                  (?>             # Non-backtracking subexp.
                      <           # Reading
                      |>>?        # Writing/appending
                  )
              )
              [^&]                # Not an ampersand (which means a dup)
          }x;
  
          if (not $mode) {
              # Maybe it's a 2-arg open without any mode at all?
              # Detect the most simple case for this, where our
              # file consists only of word characters.
  
              if ( $file =~ m{^\s*\w+\s*$} ) {
                  $mode = '<'
              }
              else {
                  # Otherwise, we've got no idea what's going on.
                  # Use the default.
                  return $this->format_default;
              }
          }
  
          # Localising $! means perl makes it a pretty error for us.
          local $! = $this->errno;
  
          return $this->_format_open_with_mode($mode, $file, $!);
      }
  
      # Here we must be using three arg open.
  
      my $file = $open_args[2];
  
      local $! = $this->errno;
  
      my $mode = $open_args[1];
  
      local $@;
  
      my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
  
      return $msg if $msg;
  
      # Default message (for pipes and odd things)
  
      return "Can't open '$file' with mode '$open_args[1]': '$!'";
  }
  
  =head3 register
  
      autodie::exception->register( 'CORE::open' => \&mysub );
  
  The C<register> method allows for the registration of a message
  handler for a given subroutine.  The full subroutine name including
  the package should be used.
  
  Registered message handlers will receive the C<autodie::exception>
  object as the first parameter.
  
  =cut
  
  sub register {
      my ($class, $symbol, $handler) = @_;
  
      croak "Incorrect call to autodie::register" if @_ != 3;
  
      $formatter_of{$symbol} = $handler;
  
  }
  
  =head3 add_file_and_line
  
      say "Problem occurred",$@->add_file_and_line;
  
  Returns the string C< at %s line %d>, where C<%s> is replaced with
  the filename, and C<%d> is replaced with the line number.
  
  Primarily intended for use by format handlers.
  
  =cut
  
  # Simply produces the file and line number; intended to be added
  # to the end of error messages.
  
  sub add_file_and_line {
      my ($this) = @_;
  
      return sprintf(" at %s line %d\n", $this->file, $this->line);
  }
  
  =head3 stringify
  
      say "The error was: ",$@->stringify;
  
  Formats the error as a human readable string.  Usually there's no
  reason to call this directly, as it is used automatically if an
  C<autodie::exception> object is ever used as a string.
  
  Child classes can override this method to change how they're
  stringified.
  
  =cut
  
  sub stringify {
      my ($this) = @_;
  
      my $call        =  $this->function;
  
      if ($DEBUG) {
          my $dying_pkg   = $this->package;
          my $sub   = $this->function;
          my $caller = $this->caller;
          warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
      }
  
      # TODO - This isn't using inheritance.  Should it?
      if ( my $sub = $formatter_of{$call} ) {
          return $sub->($this) . $this->add_file_and_line;
      }
  
      return $this->format_default . $this->add_file_and_line;
  
  }
  
  =head3 format_default
  
      my $error_string = $E->format_default;
  
  This produces the default error string for the given exception,
  I<without using any registered message handlers>.  It is primarily
  intended to be called from a message handler when they have
  been passed an exception they don't want to format.
  
  Child classes can override this method to change how default
  messages are formatted.
  
  =cut
  
  # TODO: This produces ugly errors.  Is there any way we can
  # dig around to find the actual variable names?  I know perl 5.10
  # does some dark and terrible magicks to find them for undef warnings.
  
  sub format_default {
      my ($this) = @_;
  
      my $call        =  $this->function;
  
      local $! = $this->errno;
  
      # TODO: This is probably a good idea for CORE, is it
      # a good idea for other subs?
  
      # Trim package name off dying sub for error messages.
      $call =~ s/.*:://;
  
      # Walk through all our arguments, and...
      #
      #   * Replace undef with the word 'undef'
      #   * Replace globs with the string '$fh'
      #   * Quote all other args.
  
      my @args = @{ $this->args() };
  
      foreach my $arg (@args) {
         if    (not defined($arg))   { $arg = 'undef' }
         elsif (ref($arg) eq "GLOB") { $arg = '$fh'   }
         else                        { $arg = qq{'$arg'} }
      }
  
      # Format our beautiful error.
  
      return "Can't $call(".  join(q{, }, @args) . "): $!" ;
  
      # TODO - Handle user-defined errors from hash.
  
      # TODO - Handle default error messages.
  
  }
  
  =head3 new
  
      my $error = autodie::exception->new(
          args => \@_,
          function => "CORE::open",
          errno => $!,
          context => 'scalar',
          return => undef,
      );
  
  
  Creates a new C<autodie::exception> object.  Normally called
  directly from an autodying function.  The C<function> argument
  is required, its the function we were trying to call that
  generated the exception.  The C<args> parameter is optional.
  
  The C<errno> value is optional.  In versions of C<autodie::exception>
  1.99 and earlier the code would try to automatically use the
  current value of C<$!>, but this was unreliable and is no longer
  supported.
  
  Atrributes such as package, file, and caller are determined
  automatically, and cannot be specified.
  
  =cut
  
  sub new {
      my ($class, @args) = @_;
  
      my $this = {};
  
      bless($this,$class);
  
      # I'd love to use EVERY here, but it causes our code to die
      # because it wants to stringify our objects before they're
      # initialised, causing everything to explode.
  
      $this->_init(@args);
  
      return $this;
  }
  
  sub _init {
  
      my ($this, %args) = @_;
  
      # Capturing errno here is not necessarily reliable.
      my $original_errno = $!;
  
      our $init_called = 1;
  
      my $class = ref $this;
  
      # We're going to walk up our call stack, looking for the
      # first thing that doesn't look like our exception
      # code, autodie/Fatal, or some whacky eval.
  
      my ($package, $file, $line, $sub);
  
      my $depth = 0;
  
      while (1) {
          $depth++;
  
          ($package, $file, $line, $sub) = CORE::caller($depth);
  
          # Skip up the call stack until we find something outside
          # of the Fatal/autodie/eval space.
  
          next if $package->isa('Fatal');
          next if $package->isa($class);
          next if $package->isa(__PACKAGE__);
  
          # Anything with the 'autodie::skip' role wants us to skip it.
          # https://github.com/pjf/autodie/issues/15
  
          next if ($package->can('DOES') and $package->DOES('autodie::skip'));
  
          next if $file =~ /^\(eval\s\d+\)$/;
  
          last;
  
      }
  
      # We now have everything correct, *except* for our subroutine
      # name.  If it's __ANON__ or (eval), then we need to keep on
      # digging deeper into our stack to find the real name.  However we
      # don't update our other information, since that will be correct
      # for our current exception.
  
      my $first_guess_subroutine = $sub;
  
      while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
          $depth++;
  
          $sub = (CORE::caller($depth))[3];
      }
  
      # If we end up falling out the bottom of our stack, then our
      # __ANON__ guess is the best we can get.  This includes situations
      # where we were called from the top level of a program.
  
      if (not defined $sub) {
          $sub = $first_guess_subroutine;
      }
  
      $this->{$PACKAGE}{package} = $package;
      $this->{$PACKAGE}{file}    = $file;
      $this->{$PACKAGE}{line}    = $line;
      $this->{$PACKAGE}{caller}  = $sub;
      $this->{$PACKAGE}{package} = $package;
  
      $this->{$PACKAGE}{errno}   = $args{errno} || 0;
  
      $this->{$PACKAGE}{context} = $args{context};
      $this->{$PACKAGE}{return}  = $args{return};
      $this->{$PACKAGE}{eval_error}  = $args{eval_error};
  
      $this->{$PACKAGE}{args}    = $args{args} || [];
      $this->{$PACKAGE}{function}= $args{function} or
                croak("$class->new() called without function arg");
  
      return $this;
  
  }
  
  1;
  
  __END__
  
  =head1 SEE ALSO
  
  L<autodie>, L<autodie::exception::system>
  
  =head1 LICENSE
  
  Copyright (C)2008 Paul Fenwick
  
  This is free software.  You may modify and/or redistribute this
  code under the same terms as Perl 5.10 itself, or, at your option,
  any later version of Perl 5.
  
  =head1 AUTHOR
  
  Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
AUTODIE_EXCEPTION

$fatpacked{"autodie/exception/system.pm"} = <<'AUTODIE_EXCEPTION_SYSTEM';
  package autodie::exception::system;
  use 5.008;
  use strict;
  use warnings;
  use base 'autodie::exception';
  use Carp qw(croak);
  
  our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg:Version
  
  # ABSTRACT: Exceptions from autodying system().
  
  my $PACKAGE = __PACKAGE__;
  
  =head1 NAME
  
  autodie::exception::system - Exceptions from autodying system().
  
  =head1 SYNOPSIS
  
      eval {
          use autodie qw(system);
  
          system($cmd, @args);
  
      };
  
      if (my $E = $@) {
          say "Ooops!  ",$E->caller," had problems: $@";
      }
  
  
  =head1 DESCRIPTION
  
  This is a L<autodie::exception> class for failures from the
  C<system> command.
  
  Presently there is no way to interrogate an C<autodie::exception::system>
  object for the command, exit status, and other information you'd expect
  such an object to hold.  The interface will be expanded to accommodate
  this in the future.
  
  =cut
  
  sub _init {
      my ($this, %args) = @_;
  
      $this->{$PACKAGE}{message} = $args{message}
          || croak "'message' arg not supplied to autodie::exception::system->new";
  
      return $this->SUPER::_init(%args);
  
  }
  
  =head2 stringify
  
  When stringified, C<autodie::exception::system> objects currently
  use the message generated by L<IPC::System::Simple>.
  
  =cut
  
  sub stringify {
  
      my ($this) = @_;
  
      return $this->{$PACKAGE}{message} . $this->add_file_and_line;
  
  }
  
  1;
  
  __END__
  
  =head1 LICENSE
  
  Copyright (C)2008 Paul Fenwick
  
  This is free software.  You may modify and/or redistribute this
  code under the same terms as Perl 5.10 itself, or, at your option,
  any later version of Perl 5.
  
  =head1 AUTHOR
  
  Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
AUTODIE_EXCEPTION_SYSTEM

$fatpacked{"autodie/hints.pm"} = <<'AUTODIE_HINTS';
  package autodie::hints;
  
  use strict;
  use warnings;
  
  use constant PERL58 => ( $] < 5.009 );
  
  our $VERSION = '2.20'; # VERSION: Generated by DZP::OurPkg:Version
  
  # ABSTRACT: Provide hints about user subroutines to autodie
  
  =head1 NAME
  
  autodie::hints - Provide hints about user subroutines to autodie
  
  =head1 SYNOPSIS
  
      package Your::Module;
  
      our %DOES = ( 'autodie::hints::provider' => 1 );
  
      sub AUTODIE_HINTS {
          return {
              foo => { scalar => HINTS, list => SOME_HINTS },
              bar => { scalar => HINTS, list => MORE_HINTS },
          }
      }
  
      # Later, in your main program...
  
      use Your::Module qw(foo bar);
      use autodie      qw(:default foo bar);
  
      foo();         # succeeds or dies based on scalar hints
  
      # Alternatively, hints can be set on subroutines we've
      # imported.
  
      use autodie::hints;
      use Some::Module qw(think_positive);
  
      BEGIN {
          autodie::hints->set_hints_for(
              \&think_positive,
              {
                  fail => sub { $_[0] <= 0 }
              }
          )
      }
      use autodie qw(think_positive);
  
      think_positive(...);    # Returns positive or dies.
  
  
  =head1 DESCRIPTION
  
  =head2 Introduction
  
  The L<autodie> pragma is very smart when it comes to working with
  Perl's built-in functions.  The behaviour for these functions are
  fixed, and C<autodie> knows exactly how they try to signal failure.
  
  But what about user-defined subroutines from modules?  If you use
  C<autodie> on a user-defined subroutine then it assumes the following
  behaviour to demonstrate failure:
  
  =over
  
  =item *
  
  A false value, in scalar context
  
  =item * 
  
  An empty list, in list context
  
  =item *
  
  A list containing a single undef, in list context
  
  =back
  
  All other return values (including the list of the single zero, and the
  list containing a single empty string) are considered successful.  However,
  real-world code isn't always that easy.  Perhaps the code you're working
  with returns a string containing the word "FAIL" upon failure, or a
  two element list containing C<(undef, "human error message")>.  To make
  autodie work with these sorts of subroutines, we have
  the I<hinting interface>.
  
  The hinting interface allows I<hints> to be provided to C<autodie>
  on how it should detect failure from user-defined subroutines.  While
  these I<can> be provided by the end-user of C<autodie>, they are ideally
  written into the module itself, or into a helper module or sub-class
  of C<autodie> itself.
  
  =head2 What are hints?
  
  A I<hint> is a subroutine or value that is checked against the
  return value of an autodying subroutine.  If the match returns true,
  C<autodie> considers the subroutine to have failed.
  
  If the hint provided is a subroutine, then C<autodie> will pass
  the complete return value to that subroutine.  If the hint is
  any other value, then C<autodie> will smart-match against the
  value provided.  In Perl 5.8.x there is no smart-match operator, and as such
  only subroutine hints are supported in these versions.
  
  Hints can be provided for both scalar and list contexts.  Note
  that an autodying subroutine will never see a void context, as
  C<autodie> always needs to capture the return value for examination.
  Autodying subroutines called in void context act as if they're called
  in a scalar context, but their return value is discarded after it
  has been checked.
  
  =head2 Example hints
  
  Hints may consist of scalars, array references, regular expressions and
  subroutine references.  You can specify different hints for how
  failure should be identified in scalar and list contexts.
  
  These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
  calling C<autodie::hints->set_hints_for()>.
  
  The most common context-specific hints are:
  
          # Scalar failures always return undef:
              {  scalar => undef  }
  
          # Scalar failures return any false value [default expectation]:
              {  scalar => sub { ! $_[0] }  }
  
          # Scalar failures always return zero explicitly:
              {  scalar => '0'  }
  
          # List failures always return an empty list:
              {  list => []  }
  
          # List failures return () or (undef) [default expectation]:
              {  list => sub { ! @_ || @_ == 1 && !defined $_[0] }  }
  
          # List failures return () or a single false value:
              {  list => sub { ! @_ || @_ == 1 && !$_[0] }  }
  
          # List failures return (undef, "some string")
              {  list => sub { @_ == 2 && !defined $_[0] }  }
  
          # Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context,
          #                    returns (-1) in list context...
          autodie::hints->set_hints_for(
              \&foo,
              {
                  scalar => qr/^ _? FAIL $/xms,
                  list   => [-1],
              }
          );
  
          # Unsuccessful foo() returns 0 in all contexts...
          autodie::hints->set_hints_for(
              \&foo,
              {
                  scalar => 0,
                  list   => [0],
              }
          );
  
  This "in all contexts" construction is very common, and can be
  abbreviated, using the 'fail' key.  This sets both the C<scalar>
  and C<list> hints to the same value:
  
          # Unsuccessful foo() returns 0 in all contexts...
          autodie::hints->set_hints_for(
              \&foo,
              {
                  fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 }
              }
  	);
  
          # Unsuccessful think_positive() returns negative number on failure...
          autodie::hints->set_hints_for(
              \&think_positive,
              {
                  fail => sub { $_[0] < 0 }
              }
  	);
  
          # Unsuccessful my_system() returns non-zero on failure...
          autodie::hints->set_hints_for(
              \&my_system,
              {
                  fail => sub { $_[0] != 0 }
              }
  	);
  
  =head1 Manually setting hints from within your program
  
  If you are using a module which returns something special on failure, then
  you can manually create hints for each of the desired subroutines.  Once
  the hints are specified, they are available for all files and modules loaded
  thereafter, thus you can move this work into a module and it will still
  work.
  
  	use Some::Module qw(foo bar);
  	use autodie::hints;
  
  	autodie::hints->set_hints_for(
  		\&foo,
  		{
  			scalar => SCALAR_HINT,
  			list   => LIST_HINT,
  		}
  	);
  	autodie::hints->set_hints_for(
  		\&bar,
                  { fail => SOME_HINT, }
  	);
  
  It is possible to pass either a subroutine reference (recommended) or a fully
  qualified subroutine name as the first argument.  This means you can set hints
  on modules that I<might> get loaded:
  
  	use autodie::hints;
  	autodie::hints->set_hints_for(
  		'Some::Module:bar', { fail => SCALAR_HINT, }
  	);
  
  This technique is most useful when you have a project that uses a
  lot of third-party modules.  You can define all your possible hints
  in one-place.  This can even be in a sub-class of autodie.  For
  example:
  
          package my::autodie;
  
          use parent qw(autodie);
          use autodie::hints;
  
          autodie::hints->set_hints_for(...);
  
          1;
  
  You can now C<use my::autodie>, which will work just like the standard
  C<autodie>, but is now aware of any hints that you've set.
  
  =head1 Adding hints to your module
  
  C<autodie> provides a passive interface to allow you to declare hints for
  your module.  These hints will be found and used by C<autodie> if it
  is loaded, but otherwise have no effect (or dependencies) without autodie.
  To set these, your module needs to declare that it I<does> the
  C<autodie::hints::provider> role.  This can be done by writing your
  own C<DOES> method, using a system such as C<Class::DOES> to handle
  the heavy-lifting for you, or declaring a C<%DOES> package variable
  with a C<autodie::hints::provider> key and a corresponding true value.
  
  Note that checking for a C<%DOES> hash is an C<autodie>-only
  short-cut.  Other modules do not use this mechanism for checking
  roles, although you can use the C<Class::DOES> module from the
  CPAN to allow it.
  
  In addition, you must define a C<AUTODIE_HINTS> subroutine that returns
  a hash-reference containing the hints for your subroutines:
  
          package Your::Module;
  
          # We can use the Class::DOES from the CPAN to declare adherence
          # to a role.
  
          use Class::DOES 'autodie::hints::provider' => 1;
  
          # Alternatively, we can declare the role in %DOES.  Note that
          # this is an autodie specific optimisation, although Class::DOES
          # can be used to promote this to a true role declaration.
  
          our %DOES = ( 'autodie::hints::provider' => 1 );
  
          # Finally, we must define the hints themselves.
  
  	sub AUTODIE_HINTS {
  	    return {
  	        foo => { scalar => HINTS, list => SOME_HINTS },
  	        bar => { scalar => HINTS, list => MORE_HINTS },
  	        baz => { fail => HINTS },
  	    }
  	}
  
  This allows your code to set hints without relying on C<autodie> and
  C<autodie::hints> being loaded, or even installed.  In this way your
  code can do the right thing when C<autodie> is installed, but does not
  need to depend upon it to function.
  
  =head1 Insisting on hints
  
  When a user-defined subroutine is wrapped by C<autodie>, it will
  use hints if they are available, and otherwise reverts to the
  I<default behaviour> described in the introduction of this document.
  This can be problematic if we expect a hint to exist, but (for
  whatever reason) it has not been loaded.
  
  We can ask autodie to I<insist> that a hint be used by prefixing
  an exclamation mark to the start of the subroutine name.  A lone
  exclamation mark indicates that I<all> subroutines after it must
  have hints declared.
  
  	# foo() and bar() must have their hints defined
  	use autodie qw( !foo !bar baz );
  
  	# Everything must have hints (recommended).
  	use autodie qw( ! foo bar baz );
  
  	# bar() and baz() must have their hints defined
  	use autodie qw( foo ! bar baz );
  
          # Enable autodie for all of Perl's supported built-ins,
          # as well as for foo(), bar() and baz().  Everything must
          # have hints.
          use autodie qw( ! :all foo bar baz );
  
  If hints are not available for the specified subroutines, this will cause a
  compile-time error.  Insisting on hints for Perl's built-in functions
  (eg, C<open> and C<close>) is always successful.
  
  Insisting on hints is I<strongly> recommended.
  
  =cut
  
  # TODO: implement regular expression hints
  
  use constant UNDEF_ONLY       => sub { not defined $_[0] };
  use constant EMPTY_OR_UNDEF   => sub {
      ! @_ or
      @_==1 && !defined $_[0]
  };
  
  use constant EMPTY_ONLY     => sub { @_ == 0 };
  use constant EMPTY_OR_FALSE => sub {
      ! @_ or
      @_==1 && !$_[0]
  };
  
  use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] };
  
  use constant DEFAULT_HINTS => {
      scalar => UNDEF_ONLY,
      list   => EMPTY_OR_UNDEF,
  };
  
  
  use constant HINTS_PROVIDER => 'autodie::hints::provider';
  
  use base qw(Exporter);
  
  our $DEBUG = 0;
  
  # Only ( undef ) is a strange but possible situation for very
  # badly written code.  It's not supported yet.
  
  my %Hints = (
      'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
      'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
      'File::Copy::cp'   => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
      'File::Copy::mv'   => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
  );
  
  # Start by using Sub::Identify if it exists on this system.
  
  eval { require Sub::Identify; Sub::Identify->import('get_code_info'); };
  
  # If it doesn't exist, we'll define our own.  This code is directly
  # taken from Rafael Garcia's Sub::Identify 0.04, used under the same
  # license as Perl itself.
  
  if ($@) {
      require B;
  
      no warnings 'once';
  
      *get_code_info = sub ($) {
  
          my ($coderef) = @_;
          ref $coderef or return;
          my $cv = B::svref_2object($coderef);
          $cv->isa('B::CV') or return;
          # bail out if GV is undefined
          $cv->GV->isa('B::SPECIAL') and return;
  
          return ($cv->GV->STASH->NAME, $cv->GV->NAME);
      };
  
  }
  
  sub sub_fullname {
      return join( '::', get_code_info( $_[1] ) );
  }
  
  my %Hints_loaded = ();
  
  sub load_hints {
      my ($class, $sub) = @_;
  
      my ($package) = ( $sub =~ /(.*)::/ );
  
      if (not defined $package) {
          require Carp;
          Carp::croak(
              "Internal error in autodie::hints::load_hints - no package found.
          ");
      }
  
      # Do nothing if we've already tried to load hints for
      # this package.
      return if $Hints_loaded{$package}++;
  
      my $hints_available = 0;
  
      {
          no strict 'refs';   ## no critic
  
          if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) {
              $hints_available = 1;
          }
          elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) {
              $hints_available = 1;
          }
          elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) {
              $hints_available = 1;
          }
      }
  
      return if not $hints_available;
  
      my %package_hints = %{ $package->AUTODIE_HINTS };
  
      foreach my $sub (keys %package_hints) {
  
          my $hint = $package_hints{$sub};
  
          # Ensure we have a package name.
          $sub = "${package}::$sub" if $sub !~ /::/;
  
          # TODO - Currently we don't check for conflicts, should we?
          $Hints{$sub} = $hint;
  
          $class->normalise_hints(\%Hints, $sub);
      }
  
      return;
  
  }
  
  sub normalise_hints {
      my ($class, $hints, $sub) = @_;
  
      if ( exists $hints->{$sub}->{fail} ) {
  
          if ( exists $hints->{$sub}->{scalar} or
               exists $hints->{$sub}->{list}
          ) {
              # TODO: Turn into a proper diagnostic.
              require Carp;
              local $Carp::CarpLevel = 1;
              Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub");
          }
  
          # Set our scalar and list hints.
  
          $hints->{$sub}->{scalar} = 
          $hints->{$sub}->{list} = delete $hints->{$sub}->{fail};
  
          return;
  
      }
  
      # Check to make sure all our hints exist.
  
      foreach my $hint (qw(scalar list)) {
          if ( not exists $hints->{$sub}->{$hint} ) {
              # TODO: Turn into a proper diagnostic.
              require Carp;
              local $Carp::CarpLevel = 1;
              Carp::croak("$hint hint missing for $sub");
          }
      }
  
      return;
  }
  
  sub get_hints_for {
      my ($class, $sub) = @_;
  
      my $subname = $class->sub_fullname( $sub );
  
      # If we have hints loaded for a sub, then return them.
  
      if ( exists $Hints{ $subname } ) {
          return $Hints{ $subname };
      }
  
      # If not, we try to load them...
  
      $class->load_hints( $subname );
  
      # ...and try again!
  
      if ( exists $Hints{ $subname } ) {
          return $Hints{ $subname };
      }
  
      # It's the caller's responsibility to use defaults if desired.
      # This allows on autodie to insist on hints if needed.
  
      return;
  
  }
  
  sub set_hints_for {
      my ($class, $sub, $hints) = @_;
  
      if (ref $sub) {
          $sub = $class->sub_fullname( $sub );
  
          require Carp;
  
          $sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine");
      }
  
      if ($DEBUG) {
          warn "autodie::hints: Setting $sub to hints: $hints\n";
      }
  
      $Hints{ $sub } = $hints;
  
      $class->normalise_hints(\%Hints, $sub);
  
      return;
  }
  
  1;
  
  __END__
  
  
  =head1 Diagnostics
  
  =over 4
  
  =item Attempts to set_hints_for unidentifiable subroutine
  
  You've called C<< autodie::hints->set_hints_for() >> using a subroutine
  reference, but that reference could not be resolved back to a
  subroutine name.  It may be an anonymous subroutine (which can't
  be made autodying), or may lack a name for other reasons.
  
  If you receive this error with a subroutine that has a real name,
  then you may have found a bug in autodie.  See L<autodie/BUGS>
  for how to report this.
  
  =item fail hints cannot be provided with either scalar or list hints for %s
  
  When defining hints, you can either supply both C<list> and
  C<scalar> keywords, I<or> you can provide a single C<fail> keyword.
  You can't mix and match them.
  
  =item %s hint missing for %s
  
  You've provided either a C<scalar> hint without supplying
  a C<list> hint, or vice-versa.  You I<must> supply both C<scalar>
  and C<list> hints, I<or> a single C<fail> hint.
  
  =back
  
  =head1 ACKNOWLEDGEMENTS
  
  =over 
  
  =item *
  
  Dr Damian Conway for suggesting the hinting interface and providing the
  example usage.
  
  =item *
  
  Jacinta Richardson for translating much of my ideas into this
  documentation.
  
  =back
  
  =head1 AUTHOR
  
  Copyright 2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
  
  =head1 LICENSE
  
  This module is free software.  You may distribute it under the
  same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<autodie>, L<Class::DOES>
  
  =for Pod::Coverage get_hints_for load_hints normalise_hints sub_fullname
  
  =cut
AUTODIE_HINTS

$fatpacked{"autodie/skip.pm"} = <<'AUTODIE_SKIP';
  package autodie::skip;
  use strict;
  use warnings;
  
  our $VERSION = '2.20'; # VERSION
  
  # This package exists purely so people can inherit from it,
  # which isn't at all how roles are supposed to work, but it's
  # how people will use them anyway.
  
  if ($] < 5.010) {
      # Older Perls don't have a native ->DOES.  Let's provide a cheap
      # imitation here.
  
      *DOES = sub { return shift->isa(@_); };
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  autodie::skip - Skip a package when throwing autodie exceptions
  
  =head1 SYNPOSIS
  
      use parent qw(autodie::skip);
  
  =head1 DESCRIPTION
  
  This dummy class exists to signal that the class inheriting it should
  be skipped when reporting exceptions from autodie.  This is useful
  for utility classes like L<Path::Tiny> that wish to report the location
  of where they were called on failure.
  
  If your class has a better way of doing roles, then you should not
  load this class and instead simply say that your class I<DOES>
  C<autodie::skip> instead.
  
  =head1 AUTHOR
  
  Copyright 2013, Paul Fenwick <pjf@cpan.org>
  
  =head1 LICENSE
  
  This module is free software. You may distribute it under the same
  terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<autodie>, L<autodie::exception>
  
  =cut
AUTODIE_SKIP

$fatpacked{"namespace/clean.pm"} = <<'NAMESPACE_CLEAN';
  package namespace::clean;
  
  use warnings;
  use strict;
  
  use Package::Stash;
  
  our $VERSION = '0.24';
  our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
  
  use B::Hooks::EndOfScope 'on_scope_end';
  
  =head1 NAME
  
  namespace::clean - Keep imports and functions out of your namespace
  
  =head1 SYNOPSIS
  
    package Foo;
    use warnings;
    use strict;
  
    use Carp qw(croak);   # 'croak' will be removed
  
    sub bar { 23 }        # 'bar' will be removed
  
    # remove all previously defined functions
    use namespace::clean;
  
    sub baz { bar() }     # 'baz' still defined, 'bar' still bound
  
    # begin to collection function names from here again
    no namespace::clean;
  
    sub quux { baz() }    # 'quux' will be removed
  
    # remove all functions defined after the 'no' unimport
    use namespace::clean;
  
    # Will print: 'No', 'No', 'Yes' and 'No'
    print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
    print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
    print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
    print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";
  
    1;
  
  =head1 DESCRIPTION
  
  =head2 Keeping packages clean
  
  When you define a function, or import one, into a Perl package, it will
  naturally also be available as a method. This does not per se cause
  problems, but it can complicate subclassing and, for example, plugin
  classes that are included via multiple inheritance by loading them as
  base classes.
  
  The C<namespace::clean> pragma will remove all previously declared or
  imported symbols at the end of the current package's compile cycle.
  Functions called in the package itself will still be bound by their
  name, but they won't show up as methods on your class or instances.
  
  By unimporting via C<no> you can tell C<namespace::clean> to start
  collecting functions for the next C<use namespace::clean;> specification.
  
  You can use the C<-except> flag to tell C<namespace::clean> that you
  don't want it to remove a certain function or method. A common use would
  be a module exporting an C<import> method along with some functions:
  
    use ModuleExportingImport;
    use namespace::clean -except => [qw( import )];
  
  If you just want to C<-except> a single sub, you can pass it directly.
  For more than one value you have to use an array reference.
  
  =head2 Explicitly removing functions when your scope is compiled
  
  It is also possible to explicitly tell C<namespace::clean> what packages
  to remove when the surrounding scope has finished compiling. Here is an
  example:
  
    package Foo;
    use strict;
  
    # blessed NOT available
  
    sub my_class {
        use Scalar::Util qw( blessed );
        use namespace::clean qw( blessed );
  
        # blessed available
        return blessed shift;
    }
  
    # blessed NOT available
  
  =head2 Moose
  
  When using C<namespace::clean> together with L<Moose> you want to keep
  the installed C<meta> method. So your classes should look like:
  
    package Foo;
    use Moose;
    use namespace::clean -except => 'meta';
    ...
  
  Same goes for L<Moose::Role>.
  
  =head2 Cleaning other packages
  
  You can tell C<namespace::clean> that you want to clean up another package
  instead of the one importing. To do this you have to pass in the C<-cleanee>
  option like this:
  
    package My::MooseX::namespace::clean;
    use strict;
  
    use namespace::clean (); # no cleanup, just load
  
    sub import {
        namespace::clean->import(
          -cleanee => scalar(caller),
          -except  => 'meta',
        );
    }
  
  If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
  just want to remove subroutines, try L</clean_subroutines>.
  
  =head1 METHODS
  
  =head2 clean_subroutines
  
  This exposes the actual subroutine-removal logic.
  
    namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
  
  will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
  subroutines B<immediately> and not wait for scope end. If you want to have this
  effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
  it is your responsibility to make sure it runs at that time.
  
  =cut
  
  # Constant to optimise away the unused code branches
  use constant FIXUP_NEEDED => $] < 5.015_005_1;
  use constant FIXUP_RENAME_SUB => $] > 5.008_008_9 && $] < 5.013_005_1;
  {
    no strict;
    delete ${__PACKAGE__."::"}{FIXUP_NEEDED};
    delete ${__PACKAGE__."::"}{FIXUP_RENAME_SUB};
  }
  
  # Debugger fixup necessary before perl 5.15.5
  #
  # In perl 5.8.9-5.12, it assumes that sub_fullname($sub) can
  # always be used to find the CV again.
  # In perl 5.8.8 and 5.14, it assumes that the name of the glob
  # passed to entersub can be used to find the CV.
  # since we are deleting the glob where the subroutine was originally
  # defined, those assumptions no longer hold.
  #
  # So in 5.8.9-5.12 we need to move it elsewhere and point the
  # CV's name to the new glob.
  #
  # In 5.8.8 and 5.14 we move it elsewhere and rename the
  # original glob by assigning the new glob back to it.
  my $sub_utils_loaded;
  my $DebuggerFixup = sub {
    my ($f, $sub, $cleanee_stash, $deleted_stash) = @_;
  
    if (FIXUP_RENAME_SUB) {
      if (! defined $sub_utils_loaded ) {
        $sub_utils_loaded = do {
  
          # when changing version also change in Makefile.PL
          my $sn_ver = 0.04;
          eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
            or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
  
          # when changing version also change in Makefile.PL
          my $si_ver = 0.04;
          eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
            or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
  
          1;
        } ? 1 : 0;
      }
  
      if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
        my $new_fq = $deleted_stash->name . "::$f";
        Sub::Name::subname($new_fq, $sub);
        $deleted_stash->add_symbol("&$f", $sub);
      }
    }
    else {
      $deleted_stash->add_symbol("&$f", $sub);
    }
  };
  
  my $RemoveSubs = sub {
      my $cleanee = shift;
      my $store   = shift;
      my $cleanee_stash = Package::Stash->new($cleanee);
      my $deleted_stash;
  
    SYMBOL:
      for my $f (@_) {
  
          # ignore already removed symbols
          next SYMBOL if $store->{exclude}{ $f };
  
          my $sub = $cleanee_stash->get_symbol("&$f")
            or next SYMBOL;
  
          my $need_debugger_fixup =
            FIXUP_NEEDED
              &&
            $^P
              &&
            ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
          ;
  
          if (FIXUP_NEEDED && $need_debugger_fixup) {
            # convince the Perl debugger to work
            # see the comment on top of $DebuggerFixup
            $DebuggerFixup->(
              $f,
              $sub,
              $cleanee_stash,
              $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
            );
          }
  
          my @symbols = map {
              my $name = $_ . $f;
              my $def = $cleanee_stash->get_symbol($name);
              defined($def) ? [$name, $def] : ()
          } '$', '@', '%', '';
  
          $cleanee_stash->remove_glob($f);
  
          # if this perl needs no renaming trick we need to
          # rename the original glob after the fact
          # (see commend of $DebuggerFixup
          if (FIXUP_NEEDED && !FIXUP_RENAME_SUB && $need_debugger_fixup) {
            *$globref = $deleted_stash->namespace->{$f};
          }
  
          $cleanee_stash->add_symbol(@$_) for @symbols;
      }
  };
  
  sub clean_subroutines {
      my ($nc, $cleanee, @subs) = @_;
      $RemoveSubs->($cleanee, {}, @subs);
  }
  
  =head2 import
  
  Makes a snapshot of the current defined functions and installs a
  L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
  
  =cut
  
  sub import {
      my ($pragma, @args) = @_;
  
      my (%args, $is_explicit);
  
    ARG:
      while (@args) {
  
          if ($args[0] =~ /^\-/) {
              my $key = shift @args;
              my $value = shift @args;
              $args{ $key } = $value;
          }
          else {
              $is_explicit++;
              last ARG;
          }
      }
  
      my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
      if ($is_explicit) {
          on_scope_end {
              $RemoveSubs->($cleanee, {}, @args);
          };
      }
      else {
  
          # calling class, all current functions and our storage
          my $functions = $pragma->get_functions($cleanee);
          my $store     = $pragma->get_class_store($cleanee);
          my $stash     = Package::Stash->new($cleanee);
  
          # except parameter can be array ref or single value
          my %except = map {( $_ => 1 )} (
              $args{ -except }
              ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
              : ()
          );
  
          # register symbols for removal, if they have a CODE entry
          for my $f (keys %$functions) {
              next if     $except{ $f };
              next unless $stash->has_symbol("&$f");
              $store->{remove}{ $f } = 1;
          }
  
          # register EOF handler on first call to import
          unless ($store->{handler_is_installed}) {
              on_scope_end {
                  $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
              };
              $store->{handler_is_installed} = 1;
          }
  
          return 1;
      }
  }
  
  =head2 unimport
  
  This method will be called when you do a
  
    no namespace::clean;
  
  It will start a new section of code that defines functions to clean up.
  
  =cut
  
  sub unimport {
      my ($pragma, %args) = @_;
  
      # the calling class, the current functions and our storage
      my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
      my $functions = $pragma->get_functions($cleanee);
      my $store     = $pragma->get_class_store($cleanee);
  
      # register all unknown previous functions as excluded
      for my $f (keys %$functions) {
          next if $store->{remove}{ $f }
               or $store->{exclude}{ $f };
          $store->{exclude}{ $f } = 1;
      }
  
      return 1;
  }
  
  =head2 get_class_store
  
  This returns a reference to a hash in a passed package containing
  information about function names included and excluded from removal.
  
  =cut
  
  sub get_class_store {
      my ($pragma, $class) = @_;
      my $stash = Package::Stash->new($class);
      my $var = "%$STORAGE_VAR";
      $stash->add_symbol($var, {})
          unless $stash->has_symbol($var);
      return $stash->get_symbol($var);
  }
  
  =head2 get_functions
  
  Takes a class as argument and returns all currently defined functions
  in it as a hash reference with the function name as key and a typeglob
  reference to the symbol as value.
  
  =cut
  
  sub get_functions {
      my ($pragma, $class) = @_;
  
      my $stash = Package::Stash->new($class);
      return {
          map { $_ => $stash->get_symbol("&$_") }
              $stash->list_all_symbols('CODE')
      };
  }
  
  =head1 IMPLEMENTATION DETAILS
  
  This module works through the effect that a
  
    delete $SomePackage::{foo};
  
  will remove the C<foo> symbol from C<$SomePackage> for run time lookups
  (e.g., method calls) but will leave the entry alive to be called by
  already resolved names in the package itself. C<namespace::clean> will
  restore and therefor in effect keep all glob slots that aren't C<CODE>.
  
  A test file has been added to the perl core to ensure that this behaviour
  will be stable in future releases.
  
  Just for completeness sake, if you want to remove the symbol completely,
  use C<undef> instead.
  
  =head1 SEE ALSO
  
  L<B::Hooks::EndOfScope>
  
  =head1 THANKS
  
  Many thanks to Matt S Trout for the inspiration on the whole idea.
  
  =head1 AUTHORS
  
  =over
  
  =item *
  
  Robert 'phaylon' Sedlacek <rs@474.at>
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Jesse Luehrs <doy@tozt.net>
  
  =item *
  
  Peter Rabbitson <ribasushi@cpan.org>
  
  =item *
  
  Father Chrysostomos <sprout@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by L</AUTHORS>
  
  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
  
  no warnings;
  'Danger! Laws of Thermodynamics may not apply.'
NAMESPACE_CLEAN

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

$fatpacked{"strictures.pm"} = <<'STRICTURES';
  package strictures;
  
  use strict;
  use warnings FATAL => 'all';
  
  use constant _PERL_LT_5_8_4 => ($] < 5.008004) ? 1 : 0;
  
  our $VERSION = '1.004004'; # 1.4.4
  
  sub VERSION {
    for ($_[1]) {
      last unless defined && !ref && int != 1;
      die "Major version specified as $_ - this is strictures version 1";
    }
    # disable this since Foo->VERSION(undef) correctly returns the version
    # and that can happen either if our caller passes undef explicitly or
    # because the for above autovivified $_[1] - I could make it stop but
    # it's pointless since we don't want to blow up if the caller does
    # something valid either.
    no warnings 'uninitialized';
    shift->SUPER::VERSION(@_);
  }
  
  my $extra_load_states;
  
  our $Smells_Like_VCS = (-e '.git' || -e '.svn'
    || (-e '../../dist.ini' && (-e '../../.git' || -e '../../.svn')));
  
  sub import {
    strict->import;
    warnings->import(FATAL => 'all');
  
    my $extra_tests = do {
      if (exists $ENV{PERL_STRICTURES_EXTRA}) {
        if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
          die 'PERL_STRICTURES_EXTRA checks are not available on perls older than 5.8.4: '
            . "please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
        }
        $ENV{PERL_STRICTURES_EXTRA};
      } elsif (! _PERL_LT_5_8_4) {
        !!((caller)[1] =~ /^(?:t|xt|lib|blib)/
           and $Smells_Like_VCS)
      }
    };
    if ($extra_tests) {
      $extra_load_states ||= do {
  
        my (%rv, @failed);
        foreach my $mod (qw(indirect multidimensional bareword::filehandles)) {
          eval "require $mod; \$rv{'$mod'} = 1;" or do {
            push @failed, $mod;
  
            # courtesy of the 5.8 require bug
            # (we do a copy because 5.16.2 at least uses the same read-only
            # scalars for the qw() list and it doesn't seem worth a $^V check)
  
            (my $file = $mod) =~ s|::|/|g;
            delete $INC{"${file}.pm"};
          };
        }
  
        if (@failed) {
          my $failed = join ' ', @failed;
          print STDERR <<EOE;
  strictures.pm extra testing active but couldn't load all modules. Missing were:
  
    $failed
  
  Extra testing is auto-enabled in checkouts only, so if you're the author
  of a strictures-using module you need to run:
  
    cpan indirect multidimensional bareword::filehandles
  
  but these modules are not required by your users.
  EOE
        }
  
        \%rv;
      };
  
      indirect->unimport(':fatal') if $extra_load_states->{indirect};
      multidimensional->unimport if $extra_load_states->{multidimensional};
      bareword::filehandles->unimport if $extra_load_states->{'bareword::filehandles'};
    }
  }
  
  1;
  
  __END__
  =head1 NAME
  
  strictures - turn on strict and make all warnings fatal
  
  =head1 SYNOPSIS
  
    use strictures 1;
  
  is equivalent to
  
    use strict;
    use warnings FATAL => 'all';
  
  except when called from a file which matches:
  
    (caller)[1] =~ /^(?:t|xt|lib|blib)/
  
  and when either C<.git> or C<.svn> is present in the current directory (with
  the intention of only forcing extra tests on the author side) -- or when C<.git>
  or C<.svn> is present two directories up along with C<dist.ini> (which would
  indicate we are in a C<dzil test> operation, via L<Dist::Zilla>) --
  or when the C<PERL_STRICTURES_EXTRA> environment variable is set, in which case
  
    use strictures 1;
  
  is equivalent to
  
    use strict;
    use warnings FATAL => 'all';
    no indirect 'fatal';
    no multidimensional;
    no bareword::filehandles;
  
  Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with only a minor
  version increase, but any changes to the effect of C<use strictures> in
  normal mode will involve a major version bump.
  
  If any of the extra testing modules are not present, L<strictures> will
  complain loudly, once, via C<warn()>, and then shut up. But you really
  should consider installing them, they're all great anti-footgun tools.
  
  =head1 DESCRIPTION
  
  I've been writing the equivalent of this module at the top of my code for
  about a year now. I figured it was time to make it shorter.
  
  Things like the importer in C<use Moose> don't help me because they turn
  warnings on but don't make them fatal -- which from my point of view is
  useless because I want an exception to tell me my code isn't warnings-clean.
  
  Any time I see a warning from my code, that indicates a mistake.
  
  Any time my code encounters a mistake, I want a crash -- not spew to STDERR
  and then unknown (and probably undesired) subsequent behaviour.
  
  I also want to ensure that obvious coding mistakes, like indirect object
  syntax (and not so obvious mistakes that cause things to accidentally compile
  as such) get caught, but not at the cost of an XS dependency and not at the
  cost of blowing things up on another machine.
  
  Therefore, L<strictures> turns on additional checking, but only when it thinks
  it's running in a test file in a VCS checkout -- although if this causes
  undesired behaviour this can be overridden by setting the
  C<PERL_STRICTURES_EXTRA> environment variable.
  
  If additional useful author side checks come to mind, I'll add them to the
  C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version increase (e.g.
  1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the mechanism of
  this code will result in a sub-version increase (e.g. 1.000000 to 1.000001
  (1.0.1)).
  
  If the behaviour of C<use strictures> in normal mode changes in any way, that
  will constitute a major version increase -- and the code already checks
  when its version is tested to ensure that
  
    use strictures 1;
  
  will continue to only introduce the current set of strictures even if 2.0 is
  installed.
  
  =head1 METHODS
  
  =head2 import
  
  This method does the setup work described above in L</DESCRIPTION>
  
  =head2 VERSION
  
  This method traps the C<< strictures->VERSION(1) >> call produced by a use line
  with a version number on it and does the version check.
  
  =head1 EXTRA TESTING RATIONALE
  
  Every so often, somebody complains that they're deploying via C<git pull>
  and that they don't want L<strictures> to enable itself in this case -- and that
  setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
  disable extra testing would be welcome but the discussion never seems to get
  that far).
  
  In order to allow us to skip a couple of stages and get straight to a
  productive conversation, here's my current rationale for turning the
  extra testing on via a heuristic:
  
  The extra testing is all stuff that only ever blows up at compile time;
  this is intentional. So the oft-raised concern that it's different code being
  tested is only sort of the case -- none of the modules involved affect the
  final optree to my knowledge, so the author gets some additional compile
  time crashes which he/she then fixes, and the rest of the testing is
  completely valid for all environments.
  
  The point of the extra testing -- especially C<no indirect> -- is to catch
  mistakes that newbie users won't even realise are mistakes without
  help. For example,
  
    foo { ... };
  
  where foo is an & prototyped sub that you forgot to import -- this is
  pernicious to track down since all I<seems> fine until it gets called
  and you get a crash. Worse still, you can fail to have imported it due
  to a circular require, at which point you have a load order dependent
  bug which I've seen before now I<only> show up in production due to tiny
  differences between the production and the development environment. I wrote
  L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
  this particular problem before L<strictures> itself existed.
  
  As such, in my experience so far L<strictures>' extra testing has
  I<avoided> production versus development differences, not caused them.
  
  Additionally, L<strictures>' policy is very much "try and provide as much
  protection as possible for newbies -- who won't think about whether there's
  an option to turn on or not" -- so having only the environment variable
  is not sufficient to achieve that (I get to explain that you need to add
  C<use strict> at least once a week on freenode #perl -- newbies sometimes
  completely skip steps because they don't understand that that step
  is important).
  
  I make no claims that the heuristic is perfect -- it's already been evolved
  significantly over time, especially for 1.004 where we changed things to
  ensure it only fires on files in your checkout (rather than L<strictures>-using
  modules you happened to have installed, which was just silly). However, I
  hope the above clarifies why a heuristic approach is not only necessary but
  desirable from a point of view of providing new users with as much safety as possible,
  and will allow any future discussion on the subject to focus on "how do we
  minimise annoyance to people deploying from checkouts intentionally".
  
  =head1 COMMUNITY AND SUPPORT
  
  =head2 IRC channel
  
  irc.perl.org #toolchain
  
  (or bug 'mst' in query on there or freenode)
  
  =head2 Git repository
  
  Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
  
    git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
  
  The web interface to the repository is at:
  
    http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
  
  =head1 AUTHOR
  
  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  None required yet. Maybe this module is perfect (hahahahaha ...).
  
  =head1 COPYRIGHT
  
  Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
STRICTURES

$fatpacked{"x86_64-linux/Class/XSAccessor.pm"} = <<'X86_64-LINUX_CLASS_XSACCESSOR';
  package Class::XSAccessor;
  use 5.008;
  use strict;
  use warnings;
  use Carp qw/croak/;
  use Class::XSAccessor::Heavy;
  use XSLoader;
  
  our $VERSION = '1.18';
  
  XSLoader::load('Class::XSAccessor', $VERSION);
  
  sub _make_hash {
    my $ref = shift;
  
    if (ref ($ref)) {
      if (ref($ref) eq 'ARRAY') {
        $ref = { map { $_ => $_ } @$ref }
      } 
    } else {
      $ref = { $ref, $ref };
    }
  
    return $ref;
  }
  
  sub import {
    my $own_class = shift;
    my ($caller_pkg) = caller();
  
    # Support both { getters => ... } and plain getters => ...
    my %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
  
    $caller_pkg = $opts{class} if defined $opts{class};
  
    # TODO: Refactor. Move more duplicated code to ::Heavy
    my $read_subs      = _make_hash($opts{getters} || {});
    my $set_subs       = _make_hash($opts{setters} || {});
    my $acc_subs       = _make_hash($opts{accessors} || {});
    my $lvacc_subs     = _make_hash($opts{lvalue_accessors} || {});
    my $pred_subs      = _make_hash($opts{predicates} || {});
    my $ex_pred_subs   = _make_hash($opts{exists_predicates} || {});
    my $def_pred_subs  = _make_hash($opts{defined_predicates} || {});
    my $test_subs      = _make_hash($opts{__tests__} || {});
    my $construct_subs = $opts{constructors} || [defined($opts{constructor}) ? $opts{constructor} : ()];
    my $true_subs      = $opts{true} || [];
    my $false_subs     = $opts{false} || [];
  
    foreach my $subtype ( ["getter", $read_subs],
                          ["setter", $set_subs],
                          ["accessor", $acc_subs],
                          ["lvalue_accessor", $lvacc_subs],
                          ["test", $test_subs],
                          ["ex_predicate", $ex_pred_subs],
                          ["def_predicate", $def_pred_subs],
                          ["def_predicate", $pred_subs] )
    {
      my $subs = $subtype->[1];
      foreach my $subname (keys %$subs) {
        my $hashkey = $subs->{$subname};
        _generate_method($caller_pkg, $subname, $hashkey, \%opts, $subtype->[0]);
      }
    }
  
    foreach my $subtype ( ["constructor", $construct_subs],
                          ["true", $true_subs],
                          ["false", $false_subs] )
    {
      foreach my $subname (@{$subtype->[1]}) {
        _generate_method($caller_pkg, $subname, "", \%opts, $subtype->[0]);
      }
    }
  }
  
  sub _generate_method {
    my ($caller_pkg, $subname, $hashkey, $opts, $type) = @_;
  
    croak("Cannot use undef as a hash key for generating an XS $type accessor. (Sub: $subname)")
      if not defined $hashkey;
  
    $subname = "${caller_pkg}::$subname" if $subname !~ /::/;
  
    Class::XSAccessor::Heavy::check_sub_existence($subname) if not $opts->{replace};
    no warnings 'redefine'; # don't warn about an explicitly requested redefine
  
    if ($type eq 'getter') {
      newxs_getter($subname, $hashkey);
    }
    elsif ($type eq 'lvalue_accessor') {
      newxs_lvalue_accessor($subname, $hashkey);
    }
    elsif ($type eq 'setter') {
      newxs_setter($subname, $hashkey, $opts->{chained}||0);
    }
    elsif ($type eq 'def_predicate') {
      newxs_defined_predicate($subname, $hashkey);
    }
    elsif ($type eq 'ex_predicate') {
      newxs_exists_predicate($subname, $hashkey);
    }
    elsif ($type eq 'constructor') {
      newxs_constructor($subname);
    }
    elsif ($type eq 'true') {
      newxs_boolean($subname, 1);
    }
    elsif ($type eq 'false') {
      newxs_boolean($subname, 0);
    }
    elsif ($type eq 'test') {
      newxs_test($subname, $hashkey);
    }
    else {
      newxs_accessor($subname, $hashkey, $opts->{chained}||0);
    }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Class::XSAccessor - Generate fast XS accessors without runtime compilation
  
  =head1 SYNOPSIS
  
    package MyClass;
    use Class::XSAccessor
      replace     => 1,   # Replace existing methods (if any)
      constructor => 'new',
      getters     => {
        get_foo => 'foo', # 'foo' is the hash key to access
        get_bar => 'bar',
      },
      setters => {
        set_foo => 'foo',
        set_bar => 'bar',
      },
      accessors => {
        foo => 'foo',
        bar => 'bar',
      },
      # "predicates" is an alias for "defined_predicates"
      defined_predicates => {
        defined_foo => 'foo',
        defined_bar => 'bar',
      },
      exists_predicates => {
        has_foo => 'foo',
        has_bar => 'bar',
      },
      lvalue_accessors => { # see below
        baz => 'baz', # ...
      },
      true  => [ 'is_token', 'is_whitespace' ],
      false => [ 'significant' ];
    
    # The imported methods are implemented in fast XS.
    
    # normal class code here.
  
  As of version 1.05, some alternative syntax forms are available:
  
    package MyClass;
    
    # Options can be passed as a HASH reference, if preferred,
    # which can also help Perl::Tidy to format the statement correctly.
    use Class::XSAccessor {
       # If the name => key values are always identical,
       # the following shorthand can be used.
       accessors => [ 'foo', 'bar' ],
    };
  
  =head1 DESCRIPTION
  
  Class::XSAccessor implements fast read, write and read/write accessors in XS.
  Additionally, it can provide predicates such as C<has_foo()> for testing
  whether the attribute C<foo> exists in the object (which is different from
  "is defined within the object").
  It only works with objects that are implemented as ordinary hashes.
  L<Class::XSAccessor::Array> implements the same interface for objects
  that use arrays for their internal representation.
  
  Since version 0.10, the module can also generate simple constructors
  (implemented in XS). Simply supply the
  C<constructor =E<gt> 'constructor_name'> option or the
  C<constructors =E<gt> ['new', 'create', 'spawn']> option.
  These constructors do the equivalent of the following Perl code:
  
    sub new {
      my $class = shift;
      return bless { @_ }, ref($class)||$class;
    }
  
  That means they can be called on objects and classes but will not
  clone objects entirely. Parameters to C<new()> are added to the
  object.
  
  The XS accessor methods are between 3 and 4 times faster than typical
  pure-Perl accessors in some simple benchmarking.
  The lower factor applies to the potentially slightly obscure
  C<sub set_foo_pp {$_[0]-E<gt>{foo} = $_[1]}>, so if you usually
  write clear code, a factor of 3.5 speed-up is a good estimate.
  If in doubt, do your own benchmarking!
  
  The method names may be fully qualified. The example in the synopsis could
  have been written as C<MyClass::get_foo> instead
  of C<get_foo>. This way, methods can be installed in classes other
  than the current class. See also: the C<class> option below.
  
  By default, the setters return the new value that was set,
  and the accessors (mutators) do the same. This behaviour can be changed
  with the C<chained> option - see below. The predicates return a boolean.
  
  Since version 1.01, C<Class::XSAccessor> can generate extremely simple methods which
  just return true or false (and always do so). If that seems like a
  really superfluous thing to you, then consider a large class hierarchy
  with interfaces such as L<PPI>. These methods are provided by the C<true>
  and C<false> options - see the synopsis.
  
  C<defined_predicates> check whether a given object attribute is defined.
  C<predicates> is an alias for C<defined_predicates> for compatibility with
  older versions of C<Class::XSAccessor>. C<exists_predicates> checks
  whether the given attribute exists in the object using C<exists>.
  
  =head1 OPTIONS
  
  In addition to specifying the types and names of accessors, additional options
  can be supplied which modify behaviour. The options are specified as key/value pairs
  in the same manner as the accessor declaration. For example:
  
    use Class::XSAccessor
      getters => {
        get_foo => 'foo',
      },
      replace => 1;
  
  The list of available options is:
  
  =head2 replace
  
  Set this to a true value to prevent C<Class::XSAccessor> from
  complaining about replacing existing subroutines.
  
  =head2 chained
  
  Set this to a true value to change the return value of setters
  and mutators (when called with an argument).
  If C<chained> is enabled, the setters and accessors/mutators will
  return the object. Mutators called without an argument still
  return the value of the associated attribute.
  
  As with the other options, C<chained> affects all methods generated
  in the same C<use Class::XSAccessor ...> statement.
  
  =head2 class
  
  By default, the accessors are generated in the calling class. The
  the C<class> option allows the target class to be specified.
  
  =head1 LVALUES
  
  Support for lvalue accessors via the keyword C<lvalue_accessors>
  was added in version 1.08. At this point, B<THEY ARE CONSIDERED HIGHLY
  EXPERIMENTAL>. Furthermore, their performance hasn't been benchmarked
  yet.
  
  The following example demonstrates an lvalue accessor:
  
    package Address;
    use Class::XSAccessor
      constructor => 'new',
      lvalue_accessors => { zip_code => 'zip' };
    
    package main;
    my $address = Address->new(zip => 2);
    print $address->zip_code, "\n"; # prints 2
    $address->zip_code = 76135; # <--- This is it!
    print $address->zip_code, "\n"; # prints 76135
  
  =head1 CAVEATS
  
  Probably won't work for objects based on I<tied> hashes. But that's a strange thing to do anyway.
  
  Scary code exploiting strange XS features.
  
  If you think writing an accessor in XS should be a laughably simple exercise, then
  please contemplate how you could instantiate a new XS accessor for a new hash key
  that's only known at run-time. Note that compiling C code at run-time a la L<Inline::C|Inline::C>
  is a no go.
  
  Threading. With version 1.00, a memory leak has been B<fixed>. Previously, a small amount of
  memory would leak if C<Class::XSAccessor>-based classes were loaded in a subthread without having
  been loaded in the "main" thread. If the subthread then terminated, a hash key and an int per
  associated method used to be lost. Note that this mattered only if classes were B<only> loaded
  in a sort of throw-away thread.
  
  In the new implementation, as of 1.00, the memory will still not be released, in the same situation,
  but it will be recycled when the same class, or a similar class, is loaded again in B<any> thread.
  
  =head1 SEE ALSO
  
  =over
  
  =item * L<Class::XSAccessor::Array>
  
  =item * L<AutoXS>
  
  =back
  
  =head1 AUTHOR
  
  Steffen Mueller E<lt>smueller@cpan.orgE<gt>
  
  chocolateboy E<lt>chocolate@cpan.orgE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 by Steffen Mueller
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.8 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
X86_64-LINUX_CLASS_XSACCESSOR

$fatpacked{"x86_64-linux/Class/XSAccessor/Array.pm"} = <<'X86_64-LINUX_CLASS_XSACCESSOR_ARRAY';
  package Class::XSAccessor::Array;
  use 5.008;
  use strict;
  use warnings;
  use Carp qw/croak/;
  use Class::XSAccessor;
  use Class::XSAccessor::Heavy;
  
  our $VERSION = '1.18';
  
  sub import {
    my $own_class = shift;
    my ($caller_pkg) = caller();
  
    # Support both { getters => ... } and plain getters => ...
    my %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
  
    $caller_pkg = $opts{class} if defined $opts{class};
  
    my $read_subs      = $opts{getters} || {};
    my $set_subs       = $opts{setters} || {};
    my $acc_subs       = $opts{accessors} || {};
    my $lvacc_subs     = $opts{lvalue_accessors} || {};
    my $pred_subs      = $opts{predicates} || {};
    my $construct_subs = $opts{constructors} || [defined($opts{constructor}) ? $opts{constructor} : ()];  
    my $true_subs      = $opts{true} || [];
    my $false_subs     = $opts{false} || [];
  
  
    foreach my $subtype ( ["getter", $read_subs],
                          ["setter", $set_subs],
                          ["accessor", $acc_subs],
                          ["lvalue_accessor", $lvacc_subs],
                          ["pred_subs", $pred_subs] )
    {
      my $subs = $subtype->[1];
      foreach my $subname (keys %$subs) {
        my $array_index = $subs->{$subname};
        _generate_method($caller_pkg, $subname, $array_index, \%opts, $subtype->[0]);
      }
    }
     
    foreach my $subtype ( ["constructor", $construct_subs],
                          ["true", $true_subs],
                          ["false", $false_subs] )
    {
      foreach my $subname (@{$subtype->[1]}) {
        _generate_method($caller_pkg, $subname, "", \%opts, $subtype->[0]);
      }
    }
  }
  
  sub _generate_method {
    my ($caller_pkg, $subname, $array_index, $opts, $type) = @_;
  
    croak("Cannot use undef as a array index for generating an XS $type accessor. (Sub: $subname)")
      if not defined $array_index;
  
    $subname = "${caller_pkg}::$subname" if $subname !~ /::/;
  
    Class::XSAccessor::Heavy::check_sub_existence($subname) if not $opts->{replace};
    no warnings 'redefine'; # don't warn about an explicitly requested redefine
  
    if ($type eq 'getter') {
      newxs_getter($subname, $array_index);
    }
    if ($type eq 'lvalue_accessor') {
      newxs_lvalue_accessor($subname, $array_index);
    }
    elsif ($type eq 'setter') {
      newxs_setter($subname, $array_index, $opts->{chained}||0);
    }
    elsif ($type eq 'predicate') {
      newxs_predicate($subname, $array_index);
    }
    elsif ($type eq 'constructor') {
      newxs_constructor($subname);
    }
    elsif ($type eq 'true') {
      Class::XSAccessor::newxs_boolean($subname, 1);
    }
    elsif ($type eq 'false') {
      Class::XSAccessor::newxs_boolean($subname, 0);
    }
    else {
      newxs_accessor($subname, $array_index, $opts->{chained}||0);
    }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Class::XSAccessor::Array - Generate fast XS accessors without runtime compilation
  
  =head1 SYNOPSIS
    
    package MyClassUsingArraysAsInternalStorage;
    use Class::XSAccessor::Array
      constructor => 'new',
      getters => {
        get_foo => 0, # 0 is the array index to access
        get_bar => 1,
      },
      setters => {
        set_foo => 0,
        set_bar => 1,
      },
      accessors => { # a mutator
        buz => 2,
      },
      predicates => { # test for definedness
        has_buz => 2,
      },
      lvalue_accessors => { # see below
        baz => 3,
      },
      true => [ 'is_token', 'is_whitespace' ],
      false => [ 'significant' ];
    
    # The imported methods are implemented in fast XS.
    
    # normal class code here.
  
  As of version 1.05, some alternative syntax forms are available:
  
    package MyClass;
    
    # Options can be passed as a HASH reference if you prefer it,
    # which can also help PerlTidy to flow the statement correctly.
    use Class::XSAccessor {
      getters => {
        get_foo => 0,
        get_bar => 1,
      },
    };
  
  =head1 DESCRIPTION
  
  The module implements fast XS accessors both for getting at and
  setting an object attribute. Additionally, the module supports
  mutators and simple predicates (C<has_foo()> like tests for definedness
  of an attributes).
  The module works only with objects
  that are implemented as B<arrays>. Using it on hash-based objects is
  bound to make your life miserable. Refer to L<Class::XSAccessor> for
  an implementation that works with hash-based objects.
  
  A simple benchmark showed a significant performance
  advantage over writing accessors in Perl.
  
  Since version 0.10, the module can also generate simple constructors
  (implemented in XS) for you. Simply supply the
  C<constructor =E<gt> 'constructor_name'> option or the
  C<constructors =E<gt> ['new', 'create', 'spawn']> option.
  These constructors do the equivalent of the following Perl code:
  
    sub new {
      my $class = shift;
      return bless [], ref($class)||$class;
    }
  
  That means they can be called on objects and classes but will not
  clone objects entirely. Note that any parameters to new() will be
  discarded! If there is a better idiom for array-based objects, let
  me know.
  
  While generally more obscure than hash-based objects,
  objects using blessed arrays as internal representation
  are a bit faster as its somewhat faster to access arrays than hashes.
  Accordingly, this module is slightly faster (~10-15%) than
  L<Class::XSAccessor>, which works on hash-based objects.
  
  The method names may be fully qualified. In the example of the
  synopsis, you could have written C<MyClass::get_foo> instead
  of C<get_foo>. This way, you can install methods in classes other
  than the current class. See also: The C<class> option below.
  
  Since version 1.01, you can generate extremely simple methods which
  just return true or false (and always do so). If that seems like a
  really superfluous thing to you, then think of a large class hierarchy
  with interfaces such as PPI. This is implemented as the C<true>
  and C<false> options, see synopsis.
  
  =head1 OPTIONS
  
  In addition to specifying the types and names of accessors, you can add options
  which modify behaviour. The options are specified as key/value pairs just as the
  accessor declaration. Example:
  
    use Class::XSAccessor::Array
      getters => {
        get_foo => 0,
      },
      replace => 1;
  
  The list of available options is:
  
  =head2 replace
  
  Set this to a true value to prevent C<Class::XSAccessor::Array> from
  complaining about replacing existing subroutines.
  
  =head2 chained
  
  Set this to a true value to change the return value of setters
  and mutators (when called with an argument).
  If C<chained> is enabled, the setters and accessors/mutators will
  return the object. Mutators called without an argument still
  return the value of the associated attribute.
  
  As with the other options, C<chained> affects all methods generated
  in the same C<use Class::XSAccessor::Array ...> statement.
  
  =head2 class
  
  By default, the accessors are generated in the calling class. Using
  the C<class> option, you can explicitly specify where the methods
  are to be generated.
  
  =head1 LVALUES
  
  Support for lvalue accessors via the keyword C<lvalue_accessors>
  was added in version 1.08. At this point, B<THEY ARE CONSIDERED HIGHLY
  EXPERIMENTAL>. Furthermore, their performance hasn't been benchmarked
  yet.
  
  The following example demonstrates an lvalue accessor:
  
    package Address;
    use Class::XSAccessor
      constructor => 'new',
      lvalue_accessors => { zip_code => 0 };
    
    package main;
    my $address = Address->new(2);
    print $address->zip_code, "\n"; # prints 2
    $address->zip_code = 76135; # <--- This is it!
    print $address->zip_code, "\n"; # prints 76135
  
  =head1 CAVEATS
  
  Probably wouldn't work if your objects are I<tied>. But that's a strange thing to do anyway.
  
  Scary code exploiting strange XS features.
  
  If you think writing an accessor in XS should be a laughably simple exercise, then
  please contemplate how you could instantiate a new XS accessor for a new hash key
  or array index that's only known at run-time. Note that compiling C code at run-time
  a la Inline::C is a no go.
  
  Threading. With version 1.00, a memory leak has been B<fixed> that would leak a small amount of
  memory if you loaded C<Class::XSAccessor>-based classes in a subthread that hadn't been loaded
  in the "main" thread before. If the subthread then terminated, a hash key and an int per
  associated method used ot be lost. Note that this mattered only if classes were B<only> loaded
  in a sort of throw-away thread.
  
  In the new implementation as of 1.00, the memory will not be released again either in the above
  situation. But it will be recycled when the same class or a similar class is loaded
  again in B<any> thread.
  
  =head1 SEE ALSO
  
  L<Class::XSAccessor>
  
  L<AutoXS>
  
  =head1 AUTHOR
  
  Steffen Mueller E<lt>smueller@cpan.orgE<gt>
  
  chocolateboy E<lt>chocolate@cpan.orgE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 by Steffen Mueller
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.8 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
X86_64-LINUX_CLASS_XSACCESSOR_ARRAY

$fatpacked{"x86_64-linux/Class/XSAccessor/Heavy.pm"} = <<'X86_64-LINUX_CLASS_XSACCESSOR_HEAVY';
  package # hide from PAUSE
      Class::XSAccessor::Heavy;
  
  use 5.008;
  use strict;
  use warnings;
  use Carp;
  
  our $VERSION  = '1.18';
  our @CARP_NOT = qw(
          Class::XSAccessor
          Class::XSAccessor::Array
  );
  
  # TODO Move more duplicated code from XSA and XSA::Array here
  
  
  sub check_sub_existence {
    my $subname = shift;
  
    my $sub_package = $subname;
    $sub_package =~ s/([^:]+)$// or die;
    my $bare_subname = $1;
      
    my $sym;
    {
      no strict 'refs';
      $sym = \%{"$sub_package"};
    }
    no warnings;
    local *s = $sym->{$bare_subname};
    my $coderef = *s{CODE};
    if ($coderef) {
      $sub_package =~ s/::$//;
      Carp::croak("Cannot replace existing subroutine '$bare_subname' in package '$sub_package' with an XS implementation. If you wish to force a replacement, add the 'replace => 1' parameter to the arguments of 'use ".(caller())[0]."'.");
    }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Class::XSAccessor::Heavy - Guts you don't care about
  
  =head1 SYNOPSIS
    
    use Class::XSAccessor!
  
  =head1 DESCRIPTION
  
  Common guts for Class::XSAccessor and Class::XSAccessor::Array.
  No user-serviceable parts inside!
  
  =head1 SEE ALSO
  
  L<Class::XSAccessor>
  L<Class::XSAccessor::Array>
  
  =head1 AUTHOR
  
  Steffen Mueller, E<lt>smueller@cpan.orgE<gt>
  
  chocolateboy, E<lt>chocolate@cpan.orgE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 by Steffen Mueller
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.8 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
  
X86_64-LINUX_CLASS_XSACCESSOR_HEAVY

$fatpacked{"x86_64-linux/Cpanel/JSON/XS.pm"} = <<'X86_64-LINUX_CPANEL_JSON_XS';
  =head1 NAME
  
  Cpanel::JSON::XS - JSON::XS for Cpanel, fast and correct serialising, also for 5.6.2
  
  =head1 SYNOPSIS
  
   use Cpanel::JSON::XS;
  
   # exported functions, they croak on error
   # and expect/generate UTF-8
  
   $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
   $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
  
   # OO-interface
  
   $coder = Cpanel::JSON::XS->new->ascii->pretty->allow_nonref;
   $pretty_printed_unencoded = $coder->encode ($perl_scalar);
   $perl_scalar = $coder->decode ($unicode_json_text);
  
   # Note that 5.6 misses most smart utf8 and encoding functionalities
   # of newer releases.
  
  =head1 DESCRIPTION
  
  This module converts Perl data structures to JSON and vice versa. Its
  primary goal is to be I<correct> and its secondary goal is to be
  I<fast>. To reach the latter goal it was written in C.
  
  As this is the n-th-something JSON module on CPAN, what was the reason
  to write yet another JSON module? While it seems there are many JSON
  modules, none of them correctly handle all corner cases, and in most cases
  their maintainers are unresponsive, gone missing, or not listening to bug
  reports for other reasons.
  
  See below for the Cpanel fork.
  
  See MAPPING, below, on how Cpanel::JSON::XS maps perl values to JSON
  values and vice versa.
  
  =head2 FEATURES
  
  =over 4
  
  =item * smart Unicode handling
  
  This module knows how to handle Unicode with Perl version higher than 5.8.5,
  documents how and when it does so, and even documents what "correct" means.
  
  =item * round-trip integrity
  
  When you serialise a perl data structure using only data types supported
  by JSON and Perl, the deserialised data structure is identical on the Perl
  level. (e.g. the string "2.0" doesn't suddenly become "2" just because
  it looks like a number). There I<are> minor exceptions to this, read the
  MAPPING section below to learn about those.
  
  =item * strict checking of JSON correctness
  
  There is no guessing, no generating of illegal JSON texts by default,
  and only JSON is accepted as input by default (the latter is a security
  feature).
  
  =item * fast
  
  Compared to other JSON modules and other serialisers such as Storable,
  this module usually compares favourably in terms of speed, too.
  
  =item * simple to use
  
  This module has both a simple functional interface as well as an object
  oriented interface interface.
  
  =item * reasonably versatile output formats
  
  You can choose between the most compact guaranteed-single-line format
  possible (nice for simple line-based protocols), a pure-ASCII format
  (for when your transport is not 8-bit clean, still supports the whole
  Unicode range), or a pretty-printed format (for when you want to read that
  stuff). Or you can combine those features in whatever way you like.
  
  =back
  
  =head2 cPanel fork
  
  Since the original author MLEHMANN has no public
  source repo or bugtracker, this cPanel fork sits now
  on github.
  
  src repo: L<https://github.com/rurban/Cpanel-JSON-XS>
  
  RT:       L<https://rt.cpan.org/Public/Dist/Display.html?Queue=Cpanel-JSON-XS>
  
  Changes to JSON::XS
  
  - added C<binary> method, allow \xNN and \NNN sequences with binary
  
  - 5.6.2 support, sacrificing some utf8 features (assuming bytes all-over),
    no multi-byte unicode characters.
  
  - use ppport.h, sanify XS.xs comment styles, harness C coding style
  
  - common::sense is optional. When available it is not used in the published
    production module, just during development and testing.
  
  =cut
  
  package Cpanel::JSON::XS;
  
  our $VERSION = '2.3313';
  our @ISA = qw(Exporter);
  
  our @EXPORT = qw(encode_json decode_json to_json from_json);
  
  sub to_json($@) {
     if ($] >= 5.008) {
       require Carp;
       Carp::croak ("Cpanel::JSON::XS::to_json has been renamed to encode_json, either downgrade to pre-2.0 versions of Cpanel::JSON::XS or rename the call");
     } else {
       to_json_(@_);
     }
  }
  
  sub from_json($@) {
     if ($] >= 5.008) {
       require Carp;
       Carp::croak ("Cpanel::JSON::XS::from_json has been renamed to decode_json, either downgrade to pre-2.0 versions of Cpanel::JSON::XS or rename the call");
     } else {
       from_json_(@_);
     }
  }
  
  use Exporter;
  use XSLoader;
  
  =head1 FUNCTIONAL INTERFACE
  
  The following convenience methods are provided by this module. They are
  exported by default:
  
  =over 4
  
  =item $json_text = encode_json $perl_scalar
  
  Converts the given Perl data structure to a UTF-8 encoded, binary string
  (that is, the string contains octets only). Croaks on error.
  
  This function call is functionally identical to:
  
     $json_text = Cpanel::JSON::XS->new->utf8->encode ($perl_scalar)
  
  Except being faster.
  
  =item $perl_scalar = decode_json $json_text
  
  The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
  to parse that as an UTF-8 encoded JSON text, returning the resulting
  reference. Croaks on error.
  
  This function call is functionally identical to:
  
     $perl_scalar = Cpanel::JSON::XS->new->utf8->decode ($json_text)
  
  Except being faster.
  
  =item $is_boolean = Cpanel::JSON::XS::is_bool $scalar
  
  Returns true if the passed scalar represents either Cpanel::JSON::XS::true or
  Cpanel::JSON::XS::false, two constants that act like C<1> and C<0>, respectively
  and are used to represent JSON C<true> and C<false> values in Perl.
  
  See MAPPING, below, for more information on how JSON values are mapped to
  Perl.
  
  =back
  
  
  =head1 A FEW NOTES ON UNICODE AND PERL
  
  Since this often leads to confusion, here are a few very clear words on
  how Unicode works in Perl, modulo bugs.
  
  =over 4
  
  =item 1. Perl strings can store characters with ordinal values > 255.
  
  This enables you to store Unicode characters as single characters in a
  Perl string - very natural.
  
  =item 2. Perl does I<not> associate an encoding with your strings.
  
  ... until you force it to, e.g. when matching it against a regex, or
  printing the scalar to a file, in which case Perl either interprets your
  string as locale-encoded text, octets/binary, or as Unicode, depending
  on various settings. In no case is an encoding stored together with your
  data, it is I<use> that decides encoding, not any magical meta data.
  
  =item 3. The internal utf-8 flag has no meaning with regards to the
  encoding of your string.
  
  =item 4. A "Unicode String" is simply a string where each character can be
  validly interpreted as a Unicode code point.
  
  If you have UTF-8 encoded data, it is no longer a Unicode string, but a
  Unicode string encoded in UTF-8, giving you a binary string.
  
  =item 5. A string containing "high" (> 255) character values is I<not> a UTF-8 string.
  
  =back
  
  I hope this helps :)
  
  
  =head1 OBJECT-ORIENTED INTERFACE
  
  The object oriented interface lets you configure your own encoding or
  decoding style, within the limits of supported formats.
  
  =over 4
  
  =item $json = new Cpanel::JSON::XS
  
  Creates a new JSON object that can be used to de/encode JSON
  strings. All boolean flags described below are by default I<disabled>.
  
  The mutators for flags all return the JSON object again and thus calls can
  be chained:
  
     my $json = Cpanel::JSON::XS->new->utf8->space_after->encode ({a => [1,2]})
     => {"a": [1, 2]}
  
  =item $json = $json->ascii ([$enable])
  
  =item $enabled = $json->get_ascii
  
  If C<$enable> is true (or missing), then the C<encode> method will not
  generate characters outside the code range C<0..127> (which is ASCII). Any
  Unicode characters outside that range will be escaped using either a
  single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
  as per RFC4627. The resulting encoded JSON text can be treated as a native
  Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
  or any other superset of ASCII.
  
  If C<$enable> is false, then the C<encode> method will not escape Unicode
  characters unless required by the JSON syntax or other flags. This results
  in a faster and more compact format.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this
  document.
  
  The main use for this flag is to produce JSON texts that can be
  transmitted over a 7-bit channel, as the encoded JSON texts will not
  contain any 8 bit characters.
  
    Cpanel::JSON::XS->new->ascii (1)->encode ([chr 0x10401])
    => ["\ud801\udc01"]
  
  =item $json = $json->latin1 ([$enable])
  
  =item $enabled = $json->get_latin1
  
  If C<$enable> is true (or missing), then the C<encode> method will encode
  the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
  outside the code range C<0..255>. The resulting string can be treated as a
  latin1-encoded JSON text or a native Unicode string. The C<decode> method
  will not be affected in any way by this flag, as C<decode> by default
  expects Unicode, which is a strict superset of latin1.
  
  If C<$enable> is false, then the C<encode> method will not escape Unicode
  characters unless required by the JSON syntax or other flags.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this
  document.
  
  The main use for this flag is efficiently encoding binary data as JSON
  text, as most octets will not be escaped, resulting in a smaller encoded
  size. The disadvantage is that the resulting JSON text is encoded
  in latin1 (and must correctly be treated as such when storing and
  transferring), a rare encoding for JSON. It is therefore most useful when
  you want to store data structures known to contain binary data efficiently
  in files or databases, not when talking to other JSON encoders/decoders.
  
    Cpanel::JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  =item $json = $json->binary ([$enable])
  
  =item $enabled = $json->binary
  
  If C<$enable> is true (or missing), then the C<encode> method will not
  try to detect an UTF-8 encoding in any JSON string, it will strictly
  interpret it as byte sequence.  The result might contain new \xNN
  sequences, which were not parsable by old JSON parser.  The C<decode>
  method forbids \uNNNN sequences and accepts \xNN and octal \NNN
  sequences.
  
  There is also a special logic for perl 5.6 and utf8. 5.6 encodes any
  string to utf-8 automatically when seeing a codepoint >= 0x80 and <
  0x100. With the binary flag enabled decode the perl utf8 encoded
  string to the original byte encoding and encode this with \xNN
  escapes. This will result to the same encodings as with newer
  perls. But note that binary multi-byte codepoints with 5.6 will
  result in C<illegal unicode character in binary string> errors,
  unlike with newer perls.
  
  If C<$enable> is false, then the C<encode> method will smartly try to
  detect Unicode characters unless required by the JSON syntax or other
  flags and hex and octal sequences are forbidden.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this
  document.
  
  The main use for this flag is to avoid the smart unicode detection and
  possible double encoding. The disadvantage is that the resulting JSON
  text is encoded in new \xNN and in latin1 characters and must
  correctly be treated as such when storing and transferring, a rare
  encoding for JSON.  It is therefore most useful when you want to store
  data structures known to contain binary data efficiently in files or
  databases, not when talking to other JSON encoders/decoders.
  The binary decoding method can also be used when an encoder produced a
  non-JSON conformant hex or octal encoding \xNN or \NNN.
  
    Cpanel::JSON::XS->new->binary->encode (["\x{89}\x{abc}"])
    5.6:   Error: malformed or illegal unicode character in binary string
    >=5.8: ['\x89\xe0\xaa\xbc']
  
    Cpanel::JSON::XS->new->binary->encode (["\x{89}\x{bc}"])
    => ["\x89\xbc"]
  
    Cpanel::JSON::XS->new->binary->decode (["\x89\ua001"])
    Error: malformed or illegal unicode character in binary string
  
    Cpanel::JSON::XS->new->decode (["\x89"])
    Error: illegal hex character in non-binary string
  
  =item $json = $json->utf8 ([$enable])
  
  =item $enabled = $json->get_utf8
  
  If C<$enable> is true (or missing), then the C<encode> method will encode
  the JSON result into UTF-8, as required by many protocols, while the
  C<decode> method expects to be handled an UTF-8-encoded string.  Please
  note that UTF-8-encoded strings do not contain any characters outside the
  range C<0..255>, they are thus useful for bytewise/binary I/O. In future
  versions, enabling this option might enable autodetection of the UTF-16
  and UTF-32 encoding families, as described in RFC4627.
  
  If C<$enable> is false, then the C<encode> method will return the JSON
  string as a (non-encoded) Unicode string, while C<decode> expects thus a
  Unicode string.  Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs
  to be done yourself, e.g. using the Encode module.
  
  See also the section I<ENCODING/CODESET FLAG NOTES> later in this
  document.
  
  Example, output UTF-16BE-encoded JSON:
  
    use Encode;
    $jsontext = encode "UTF-16BE", Cpanel::JSON::XS->new->encode ($object);
  
  Example, decode UTF-32LE-encoded JSON:
  
    use Encode;
    $object = Cpanel::JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
  
  =item $json = $json->pretty ([$enable])
  
  This enables (or disables) all of the C<indent>, C<space_before> and
  C<space_after> (and in the future possibly more) flags in one call to
  generate the most readable (or most compact) form possible.
  
  Example, pretty-print some simple structure:
  
     my $json = Cpanel::JSON::XS->new->pretty(1)->encode ({a => [1,2]})
     =>
     {
        "a" : [
           1,
           2
        ]
     }
  
  =item $json = $json->indent ([$enable])
  
  =item $enabled = $json->get_indent
  
  If C<$enable> is true (or missing), then the C<encode> method will use a multiline
  format as output, putting every array member or object/hash key-value pair
  into its own line, indenting them properly.
  
  If C<$enable> is false, no newlines or indenting will be produced, and the
  resulting JSON text is guaranteed not to contain any C<newlines>.
  
  This setting has no effect when decoding JSON texts.
  
  =item $json = $json->space_before ([$enable])
  
  =item $enabled = $json->get_space_before
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space before the C<:> separating keys from values in JSON objects.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts. You will also
  most likely combine this setting with C<space_after>.
  
  Example, space_before enabled, space_after and indent disabled:
  
     {"key" :"value"}
  
  =item $json = $json->space_after ([$enable])
  
  =item $enabled = $json->get_space_after
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space after the C<:> separating keys from values in JSON objects
  and extra whitespace after the C<,> separating key-value pairs and array
  members.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before and indent disabled, space_after enabled:
  
     {"key": "value"}
  
  =item $json = $json->relaxed ([$enable])
  
  =item $enabled = $json->get_relaxed
  
  If C<$enable> is true (or missing), then C<decode> will accept some
  extensions to normal JSON syntax (see below). C<encode> will not be
  affected in anyway. I<Be aware that this option makes you accept invalid
  JSON texts as if they were valid!>. I suggest only to use this option to
  parse application-specific files written by humans (configuration files,
  resource files etc.)
  
  If C<$enable> is false (the default), then C<decode> will only accept
  valid JSON texts.
  
  Currently accepted extensions are:
  
  =over 4
  
  =item * list items can have an end-comma
  
  JSON I<separates> array elements and key-value pairs with commas. This
  can be annoying if you write JSON texts manually and want to be able to
  quickly append elements, so this extension accepts comma at the end of
  such items not just between them:
  
     [
        1,
        2, <- this comma not normally allowed
     ]
     {
        "k1": "v1",
        "k2": "v2", <- this comma not normally allowed
     }
  
  =item * shell-style '#'-comments
  
  Whenever JSON allows whitespace, shell-style comments are additionally
  allowed. They are terminated by the first carriage-return or line-feed
  character, after which more white-space and comments are allowed.
  
    [
       1, # this comment not allowed in JSON
          # neither this one...
    ]
  
  =back
  
  =item $json = $json->canonical ([$enable])
  
  =item $enabled = $json->get_canonical
  
  If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
  by sorting their keys. This is adding a comparatively high overhead.
  
  If C<$enable> is false, then the C<encode> method will output key-value
  pairs in the order Perl stores them (which will likely change between runs
  of the same script).
  
  This option is useful if you want the same data structure to be encoded as
  the same JSON text (given the same overall settings). If it is disabled,
  the same hash might be encoded differently even if contains the same data,
  as key-value pairs have no inherent ordering in Perl.
  
  This setting has no effect when decoding JSON texts.
  
  This setting has currently no effect on tied hashes.
  
  =item $json = $json->allow_nonref ([$enable])
  
  =item $enabled = $json->get_allow_nonref
  
  If C<$enable> is true (or missing), then the C<encode> method can convert a
  non-reference into its corresponding string, number or null JSON value,
  which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
  values instead of croaking.
  
  If C<$enable> is false, then the C<encode> method will croak if it isn't
  passed an arrayref or hashref, as JSON texts must either be an object
  or array. Likewise, C<decode> will croak if given something that is not a
  JSON object or array.
  
  Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
  resulting in an invalid JSON text:
  
     Cpanel::JSON::XS->new->allow_nonref->encode ("Hello, World!")
     => "Hello, World!"
  
  =item $json = $json->allow_unknown ([$enable])
  
  =item $enabled = $json->get_allow_unknown
  
  If C<$enable> is true (or missing), then C<encode> will I<not> throw an
  exception when it encounters values it cannot represent in JSON (for
  example, filehandles) but instead will encode a JSON C<null> value. Note
  that blessed objects are not included here and are handled separately by
  c<allow_nonref>.
  
  If C<$enable> is false (the default), then C<encode> will throw an
  exception when it encounters anything it cannot encode as JSON.
  
  This option does not affect C<decode> in any way, and it is recommended to
  leave it off unless you know your communications partner.
  
  =item $json = $json->allow_blessed ([$enable])
  
  =item $enabled = $json->get_allow_blessed
  
  If C<$enable> is true (or missing), then the C<encode> method will not
  barf when it encounters a blessed reference. Instead, the value of the
  B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
  disabled or no C<TO_JSON> method found) or a representation of the
  object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
  encoded. Has no effect on C<decode>.
  
  If C<$enable> is false (the default), then C<encode> will throw an
  exception when it encounters a blessed object.
  
  =item $json = $json->convert_blessed ([$enable])
  
  =item $enabled = $json->get_convert_blessed
  
  If C<$enable> is true (or missing), then C<encode>, upon encountering a
  blessed object, will check for the availability of the C<TO_JSON> method
  on the object's class. If found, it will be called in scalar context
  and the resulting scalar will be encoded instead of the object. If no
  C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
  to do.
  
  The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
  returns other blessed objects, those will be handled in the same
  way. C<TO_JSON> must take care of not causing an endless recursion cycle
  (== crash) in this case. The name of C<TO_JSON> was chosen because other
  methods called by the Perl core (== not by the user of the object) are
  usually in upper case letters and to avoid collisions with any C<to_json>
  function or method.
  
  This setting does not yet influence C<decode> in any way, but in the
  future, global hooks might get installed that influence C<decode> and are
  enabled by this setting.
  
  If C<$enable> is false, then the C<allow_blessed> setting will decide what
  to do when a blessed object is found.
  
  =item $json = $json->filter_json_object ([$coderef->($hashref)])
  
  When C<$coderef> is specified, it will be called from C<decode> each
  time it decodes a JSON object. The only argument is a reference to the
  newly-created hash. If the code references returns a single scalar (which
  need not be a reference), this value (i.e. a copy of that scalar to avoid
  aliasing) is inserted into the deserialised data structure. If it returns
  an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the
  original deserialised hash will be inserted. This setting can slow down
  decoding considerably.
  
  When C<$coderef> is omitted or undefined, any existing callback will
  be removed and C<decode> will not change the deserialised hash in any
  way.
  
  Example, convert all JSON objects into the integer 5:
  
     my $js = Cpanel::JSON::XS->new->filter_json_object (sub { 5 });
     # returns [5]
     $js->decode ('[{}]')
     # throw an exception because allow_nonref is not enabled
     # so a lone 5 is not allowed.
     $js->decode ('{"a":1, "b":2}');
  
  =item $json = $json->filter_json_single_key_object ($key [=> $coderef->($value)])
  
  Works remotely similar to C<filter_json_object>, but is only called for
  JSON objects having a single key named C<$key>.
  
  This C<$coderef> is called before the one specified via
  C<filter_json_object>, if any. It gets passed the single value in the JSON
  object. If it returns a single value, it will be inserted into the data
  structure. If it returns nothing (not even C<undef> but the empty list),
  the callback from C<filter_json_object> will be called next, as if no
  single-key callback were specified.
  
  If C<$coderef> is omitted or undefined, the corresponding callback will be
  disabled. There can only ever be one callback for a given key.
  
  As this callback gets called less often then the C<filter_json_object>
  one, decoding speed will not usually suffer as much. Therefore, single-key
  objects make excellent targets to serialise Perl objects into, especially
  as single-key JSON objects are as close to the type-tagged value concept
  as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
  support this in any way, so you need to make sure your data never looks
  like a serialised Perl hash.
  
  Typical names for the single object key are C<__class_whatever__>, or
  C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
  things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
  with real hashes.
  
  Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
  into the corresponding C<< $WIDGET{<id>} >> object:
  
     # return whatever is in $WIDGET{5}:
     Cpanel::JSON::XS
        ->new
        ->filter_json_single_key_object (__widget__ => sub {
              $WIDGET{ $_[0] }
           })
        ->decode ('{"__widget__": 5')
  
     # this can be used with a TO_JSON method in some "widget" class
     # for serialisation to json:
     sub WidgetBase::TO_JSON {
        my ($self) = @_;
  
        unless ($self->{id}) {
           $self->{id} = ..get..some..id..;
           $WIDGET{$self->{id}} = $self;
        }
  
        { __widget__ => $self->{id} }
     }
  
  =item $json = $json->shrink ([$enable])
  
  =item $enabled = $json->get_shrink
  
  Perl usually over-allocates memory a bit when allocating space for
  strings. This flag optionally resizes strings generated by either
  C<encode> or C<decode> to their minimum size possible. This can save
  memory when your JSON texts are either very very long or you have many
  short strings. It will also try to downgrade any strings to octet-form
  if possible: perl stores strings internally either in an encoding called
  UTF-X or in octet-form. The latter cannot store everything but uses less
  space in general (and some buggy Perl or C code might even rely on that
  internal representation being used).
  
  The actual definition of what shrink does might change in future versions,
  but it will always try to save space at the expense of time.
  
  If C<$enable> is true (or missing), the string returned by C<encode> will
  be shrunk-to-fit, while all strings generated by C<decode> will also be
  shrunk-to-fit.
  
  If C<$enable> is false, then the normal perl allocation algorithms are used.
  If you work with your data, then this is likely to be faster.
  
  In the future, this setting might control other things, such as converting
  strings that look like integers or floats into integers or floats
  internally (there is no difference on the Perl level), saving space.
  
  =item $json = $json->max_depth ([$maximum_nesting_depth])
  
  =item $max_depth = $json->get_max_depth
  
  Sets the maximum nesting level (default C<512>) accepted while encoding
  or decoding. If a higher nesting level is detected in JSON text or a Perl
  data structure, then the encoder and decoder will stop and croak at that
  point.
  
  Nesting level is defined by number of hash- or arrayrefs that the encoder
  needs to traverse to reach a given point or the number of C<{> or C<[>
  characters without their matching closing parenthesis crossed to reach a
  given character in a string.
  
  Setting the maximum depth to one disallows any nesting, so that ensures
  that the object is only a single hash/object or array.
  
  If no argument is given, the highest possible setting will be used, which
  is rarely useful.
  
  Note that nesting is implemented by recursion in C. The default value has
  been chosen to be as large as typical operating systems allow without
  crashing.
  
  See SECURITY CONSIDERATIONS, below, for more info on why this is useful.
  
  =item $json = $json->max_size ([$maximum_string_size])
  
  =item $max_size = $json->get_max_size
  
  Set the maximum length a JSON text may have (in bytes) where decoding is
  being attempted. The default is C<0>, meaning no limit. When C<decode>
  is called on a string that is longer then this many bytes, it will not
  attempt to decode the string but throw an exception. This setting has no
  effect on C<encode> (yet).
  
  If no argument is given, the limit check will be deactivated (same as when
  C<0> is specified).
  
  See SECURITY CONSIDERATIONS, below, for more info on why this is useful.
  
  =item $json_text = $json->encode ($perl_scalar)
  
  Converts the given Perl data structure (a simple scalar or a reference
  to a hash or array) to its JSON representation. Simple scalars will be
  converted into JSON string or number sequences, while references to arrays
  become JSON arrays and references to hashes become JSON objects. Undefined
  Perl values (e.g. C<undef>) become JSON C<null> values. Neither C<true>
  nor C<false> values will be generated.
  
  =item $perl_scalar = $json->decode ($json_text)
  
  The opposite of C<encode>: expects a JSON text and tries to parse it,
  returning the resulting simple scalar or reference. Croaks on error.
  
  JSON numbers and strings become simple Perl scalars. JSON arrays become
  Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
  C<1>, C<false> becomes C<0> and C<null> becomes C<undef>.
  
  =item ($perl_scalar, $characters) = $json->decode_prefix ($json_text)
  
  This works like the C<decode> method, but instead of raising an exception
  when there is trailing garbage after the first JSON object, it will
  silently stop parsing there and return the number of characters consumed
  so far.
  
  This is useful if your JSON texts are not delimited by an outer protocol
  (which is not the brightest thing to do in the first place) and you need
  to know where the JSON text ends.
  
     Cpanel::JSON::XS->new->decode_prefix ("[1] the tail")
     => ([], 3)
  
  =back
  
  
  =head1 INCREMENTAL PARSING
  
  In some cases, there is the need for incremental parsing of JSON
  texts. While this module always has to keep both JSON text and resulting
  Perl data structure in memory at one time, it does allow you to parse a
  JSON stream incrementally. It does so by accumulating text until it has
  a full JSON object, which it then can decode. This process is similar to
  using C<decode_prefix> to see if a full JSON object is available, but
  is much more efficient (and can be implemented with a minimum of method
  calls).
  
  Cpanel::JSON::XS will only attempt to parse the JSON text once it is sure it
  has enough text to get a decisive result, using a very simple but
  truly incremental parser. This means that it sometimes won't stop as
  early as the full parser, for example, it doesn't detect mismatched
  parentheses. The only thing it guarantees is that it starts decoding as
  soon as a syntactically valid JSON text has been seen. This means you need
  to set resource limits (e.g. C<max_size>) to ensure the parser will stop
  parsing in the presence if syntax errors.
  
  The following methods implement this incremental parser.
  
  =over 4
  
  =item [void, scalar or list context] = $json->incr_parse ([$string])
  
  This is the central parsing function. It can both append new text and
  extract objects from the stream accumulated so far (both of these
  functions are optional).
  
  If C<$string> is given, then this string is appended to the already
  existing JSON fragment stored in the C<$json> object.
  
  After that, if the function is called in void context, it will simply
  return without doing anything further. This can be used to add more text
  in as many chunks as you want.
  
  If the method is called in scalar context, then it will try to extract
  exactly I<one> JSON object. If that is successful, it will return this
  object, otherwise it will return C<undef>. If there is a parse error,
  this method will croak just as C<decode> would do (one can then use
  C<incr_skip> to skip the errornous part). This is the most common way of
  using the method.
  
  And finally, in list context, it will try to extract as many objects
  from the stream as it can find and return them, or the empty list
  otherwise. For this to work, there must be no separators between the JSON
  objects or arrays, instead they must be concatenated back-to-back. If
  an error occurs, an exception will be raised as in the scalar context
  case. Note that in this case, any previously-parsed JSON texts will be
  lost.
  
  Example: Parse some JSON arrays/objects in a given string and return
  them.
  
     my @objs = Cpanel::JSON::XS->new->incr_parse ("[5][7][1,2]");
  
  =item $lvalue_string = $json->incr_text (>5.8 only)
  
  This method returns the currently stored JSON fragment as an lvalue, that
  is, you can manipulate it. This I<only> works when a preceding call to
  C<incr_parse> in I<scalar context> successfully returned an object, and
  2. only with Perl >= 5.8 
  
  Under all other circumstances you must not call this function (I mean
  it.  although in simple tests it might actually work, it I<will> fail
  under real world conditions). As a special exception, you can also
  call this method before having parsed anything.
  
  This function is useful in two cases: a) finding the trailing text after a
  JSON object or b) parsing multiple JSON objects separated by non-JSON text
  (such as commas).
  
  =item $json->incr_skip
  
  This will reset the state of the incremental parser and will remove
  the parsed text from the input buffer so far. This is useful after
  C<incr_parse> died, in which case the input buffer and incremental parser
  state is left unchanged, to skip the text parsed so far and to reset the
  parse state.
  
  The difference to C<incr_reset> is that only text until the parse error
  occured is removed.
  
  =item $json->incr_reset
  
  This completely resets the incremental parser, that is, after this call,
  it will be as if the parser had never parsed anything.
  
  This is useful if you want to repeatedly parse JSON objects and want to
  ignore any trailing data, which means you have to reset the parser after
  each successful decode.
  
  =back
  
  =head2 LIMITATIONS
  
  All options that affect decoding are supported, except
  C<allow_nonref>. The reason for this is that it cannot be made to
  work sensibly: JSON objects and arrays are self-delimited, i.e. you can concatenate
  them back to back and still decode them perfectly. This does not hold true
  for JSON numbers, however.
  
  For example, is the string C<1> a single JSON number, or is it simply the
  start of C<12>? Or is C<12> a single JSON number, or the concatenation
  of C<1> and C<2>? In neither case you can tell, and this is why Cpanel::JSON::XS
  takes the conservative route and disallows this case.
  
  =head2 EXAMPLES
  
  Some examples will make all this clearer. First, a simple example that
  works similarly to C<decode_prefix>: We want to decode the JSON object at
  the start of a string and identify the portion after the JSON object:
  
     my $text = "[1,2,3] hello";
  
     my $json = new Cpanel::JSON::XS;
  
     my $obj = $json->incr_parse ($text)
        or die "expected JSON object or array at beginning of string";
  
     my $tail = $json->incr_text;
     # $tail now contains " hello"
  
  Easy, isn't it?
  
  Now for a more complicated example: Imagine a hypothetical protocol where
  you read some requests from a TCP stream, and each request is a JSON
  array, without any separation between them (in fact, it is often useful to
  use newlines as "separators", as these get interpreted as whitespace at
  the start of the JSON text, which makes it possible to test said protocol
  with C<telnet>...).
  
  Here is how you'd do it (it is trivial to write this in an event-based
  manner):
  
     my $json = new Cpanel::JSON::XS;
  
     # read some data from the socket
     while (sysread $socket, my $buf, 4096) {
  
        # split and decode as many requests as possible
        for my $request ($json->incr_parse ($buf)) {
           # act on the $request
        }
     }
  
  Another complicated example: Assume you have a string with JSON objects
  or arrays, all separated by (optional) comma characters (e.g. C<[1],[2],
  [3]>). To parse them, we have to skip the commas between the JSON texts,
  and here is where the lvalue-ness of C<incr_text> comes in useful:
  
     my $text = "[1],[2], [3]";
     my $json = new Cpanel::JSON::XS;
  
     # void context, so no parsing done
     $json->incr_parse ($text);
  
     # now extract as many objects as possible. note the
     # use of scalar context so incr_text can be called.
     while (my $obj = $json->incr_parse) {
        # do something with $obj
  
        # now skip the optional comma
        $json->incr_text =~ s/^ \s* , //x;
     }
  
  Now lets go for a very complex example: Assume that you have a gigantic
  JSON array-of-objects, many gigabytes in size, and you want to parse it,
  but you cannot load it into memory fully (this has actually happened in
  the real world :).
  
  Well, you lost, you have to implement your own JSON parser. But Cpanel::JSON::XS
  can still help you: You implement a (very simple) array parser and let
  JSON decode the array elements, which are all full JSON objects on their
  own (this wouldn't work if the array elements could be JSON numbers, for
  example):
  
     my $json = new Cpanel::JSON::XS;
  
     # open the monster
     open my $fh, "<bigfile.json"
        or die "bigfile: $!";
  
     # first parse the initial "["
     for (;;) {
        sysread $fh, my $buf, 65536
           or die "read error: $!";
        $json->incr_parse ($buf); # void context, so no parsing
  
        # Exit the loop once we found and removed(!) the initial "[".
        # In essence, we are (ab-)using the $json object as a simple scalar
        # we append data to.
        last if $json->incr_text =~ s/^ \s* \[ //x;
     }
  
     # now we have the skipped the initial "[", so continue
     # parsing all the elements.
     for (;;) {
        # in this loop we read data until we got a single JSON object
        for (;;) {
           if (my $obj = $json->incr_parse) {
              # do something with $obj
              last;
           }
  
           # add more data
           sysread $fh, my $buf, 65536
              or die "read error: $!";
           $json->incr_parse ($buf); # void context, so no parsing
        }
  
        # in this loop we read data until we either found and parsed the
        # separating "," between elements, or the final "]"
        for (;;) {
           # first skip whitespace
           $json->incr_text =~ s/^\s*//;
  
           # if we find "]", we are done
           if ($json->incr_text =~ s/^\]//) {
              print "finished.\n";
              exit;
           }
  
           # if we find ",", we can continue with the next element
           if ($json->incr_text =~ s/^,//) {
              last;
           }
  
           # if we find anything else, we have a parse error!
           if (length $json->incr_text) {
              die "parse error near ", $json->incr_text;
           }
  
           # else add more data
           sysread $fh, my $buf, 65536
              or die "read error: $!";
           $json->incr_parse ($buf); # void context, so no parsing
        }
  
  This is a complex example, but most of the complexity comes from the fact
  that we are trying to be correct (bear with me if I am wrong, I never ran
  the above example :).
  
  
  
  =head1 MAPPING
  
  This section describes how Cpanel::JSON::XS maps Perl values to JSON values and
  vice versa. These mappings are designed to "do the right thing" in most
  circumstances automatically, preserving round-tripping characteristics
  (what you put in comes out as something equivalent).
  
  For the more enlightened: note that in the following descriptions,
  lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
  refers to the abstract Perl language itself.
  
  
  =head2 JSON -> PERL
  
  =over 4
  
  =item object
  
  A JSON object becomes a reference to a hash in Perl. No ordering of object
  keys is preserved (JSON does not preserve object key ordering itself).
  
  =item array
  
  A JSON array becomes a reference to an array in Perl.
  
  =item string
  
  A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
  are represented by the same codepoints in the Perl string, so no manual
  decoding is necessary.
  
  =item number
  
  A JSON number becomes either an integer, numeric (floating point) or
  string scalar in perl, depending on its range and any fractional parts. On
  the Perl level, there is no difference between those as Perl handles all
  the conversion details, but an integer may take slightly less memory and
  might represent more values exactly than floating point numbers.
  
  If the number consists of digits only, Cpanel::JSON::XS will try to represent
  it as an integer value. If that fails, it will try to represent it as
  a numeric (floating point) value if that is possible without loss of
  precision. Otherwise it will preserve the number as a string value (in
  which case you lose roundtripping ability, as the JSON number will be
  re-encoded toa JSON string).
  
  Numbers containing a fractional or exponential part will always be
  represented as numeric (floating point) values, possibly at a loss of
  precision (in which case you might lose perfect roundtripping ability, but
  the JSON number will still be re-encoded as a JSON number).
  
  Note that precision is not accuracy - binary floating point values cannot
  represent most decimal fractions exactly, and when converting from and to
  floating point, Cpanel::JSON::XS only guarantees precision up to but not including
  the leats significant bit.
  
  =item true, false
  
  These JSON atoms become C<JSON::XS::true> and C<JSON::XS::false>,
  respectively. They are overloaded to act almost exactly like the numbers
  C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
  the C<JSON::XS::is_bool> function.
  
  =item null
  
  A JSON null atom becomes C<undef> in Perl.
  
  =back
  
  
  =head2 PERL -> JSON
  
  The mapping from Perl to JSON is slightly more difficult, as Perl is a
  truly typeless language, so we can only guess which JSON type is meant by
  a Perl value.
  
  =over 4
  
  =item hash references
  
  Perl hash references become JSON objects. As there is no inherent ordering
  in hash keys (or JSON objects), they will usually be encoded in a
  pseudo-random order that can change between runs of the same program but
  stays generally the same within a single run of a program. Cpanel::JSON::XS can
  optionally sort the hash keys (determined by the I<canonical> flag), so
  the same datastructure will serialise to the same JSON text (given same
  settings and version of Cpanel::JSON::XS), but this incurs a runtime overhead
  and is only rarely useful, e.g. when you want to compare some JSON text
  against another for equality.
  
  =item array references
  
  Perl array references become JSON arrays.
  
  =item other references
  
  Other unblessed references are generally not allowed and will cause an
  exception to be thrown, except for references to the integers C<0> and
  C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
  also use C<JSON::XS::false> and C<JSON::XS::true> to improve readability.
  
     encode_json [\0, Cpanel::JSON::XS::true]      # yields [false,true]
  
  =item Cpanel::JSON::XS::true, Cpanel::JSON::XS::false
  
  These special values become JSON true and JSON false values,
  respectively. You can also use C<\1> and C<\0> directly if you want.
  
  =item blessed objects
  
  Blessed objects are not directly representable in JSON. See the
  C<allow_blessed> and C<convert_blessed> methods on various options on
  how to deal with this: basically, you can choose between throwing an
  exception, encoding the reference as if it weren't blessed, or provide
  your own serialiser method.
  
  =item simple scalars
  
  Simple Perl scalars (any scalar that is not a reference) are the most
  difficult objects to encode: Cpanel::JSON::XS will encode undefined scalars as
  JSON C<null> values, scalars that have last been used in a string context
  before encoding as JSON strings, and anything else as number value:
  
     # dump as number
     encode_json [2]                      # yields [2]
     encode_json [-3.0e17]                # yields [-3e+17]
     my $value = 5; encode_json [$value]  # yields [5]
  
     # used as string, so dump as string
     print $value;
     encode_json [$value]                 # yields ["5"]
  
     # undef becomes null
     encode_json [undef]                  # yields [null]
  
  You can force the type to be a JSON string by stringifying it:
  
     my $x = 3.1; # some variable containing a number
     "$x";        # stringified
     $x .= "";    # another, more awkward way to stringify
     print $x;    # perl does it for you, too, quite often
  
  You can force the type to be a JSON number by numifying it:
  
     my $x = "3"; # some variable containing a string
     $x += 0;     # numify it, ensuring it will be dumped as a number
     $x *= 1;     # same thing, the choice is yours.
  
  You can not currently force the type in other, less obscure, ways. Tell me
  if you need this capability (but don't forget to explain why it's needed
  :).
  
  Note that numerical precision has the same meaning as under Perl (so
  binary to decimal conversion follows the same rules as in Perl, which
  can differ to other languages). Also, your perl interpreter might expose
  extensions to the floating point numbers of your platform, such as
  infinities or NaN's - these cannot be represented in JSON, and it is an
  error to pass those in.
  
  =back
  
  
  =head1 ENCODING/CODESET FLAG NOTES
  
  The interested reader might have seen a number of flags that signify
  encodings or codesets - C<utf8>, C<latin1>, C<binary> and
  C<ascii>. There seems to be some confusion on what these do, so here
  is a short comparison:
  
  C<utf8> controls whether the JSON text created by C<encode> (and expected
  by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
  control whether C<encode> escapes character values outside their respective
  codeset range. Neither of these flags conflict with each other, although
  some combinations make less sense than others.
  
  Care has been taken to make all flags symmetrical with respect to
  C<encode> and C<decode>, that is, texts encoded with any combination of
  these flag values will be correctly decoded when the same flags are used
  - in general, if you use different flag settings while encoding vs. when
  decoding you likely have a bug somewhere.
  
  Below comes a verbose discussion of these flags. Note that a "codeset" is
  simply an abstract set of character-codepoint pairs, while an encoding
  takes those codepoint numbers and I<encodes> them, in our case into
  octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
  and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
  the same time, which can be confusing.
  
  =over 4
  
  =item C<utf8> flag disabled
  
  When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
  and expect Unicode strings, that is, characters with high ordinal Unicode
  values (> 255) will be encoded as such characters, and likewise such
  characters are decoded as-is, no canges to them will be done, except
  "(re-)interpreting" them as Unicode codepoints or Unicode characters,
  respectively (to Perl, these are the same thing in strings unless you do
  funny/weird/dumb stuff).
  
  This is useful when you want to do the encoding yourself (e.g. when you
  want to have UTF-16 encoded JSON texts) or when some other layer does
  the encoding for you (for example, when printing to a terminal using a
  filehandle that transparently encodes to UTF-8 you certainly do NOT want
  to UTF-8 encode your data first and have Perl encode it another time).
  
  =item C<utf8> flag enabled
  
  If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
  characters using the corresponding UTF-8 multi-byte sequence, and will
  expect your input strings to be encoded as UTF-8, that is, no "character"
  of the input string must have any value > 255, as UTF-8 does not allow
  that.
  
  The C<utf8> flag therefore switches between two modes: disabled means you
  will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
  octet/binary string in Perl.
  
  =item C<latin1>, C<binary> or C<ascii> flags enabled
  
  With C<latin1> (or C<ascii>) enabled, C<encode> will escape
  characters with ordinal values > 255 (> 127 with C<ascii>) and encode
  the remaining characters as specified by the C<utf8> flag.
  With C<binary> enabled, ordinal values > 255 are illegal.
  
  If C<utf8> is disabled, then the result is also correctly encoded in those
  character sets (as both are proper subsets of Unicode, meaning that a
  Unicode string with all character values < 256 is the same thing as a
  ISO-8859-1 string, and a Unicode string with all character values < 128 is
  the same thing as an ASCII string in Perl).
  
  If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
  regardless of these flags, just some more characters will be escaped using
  C<\uXXXX> then before.
  
  Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
  encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
  encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
  a subset of Unicode), while ASCII is.
  
  Surprisingly, C<decode> will ignore these flags and so treat all input
  values as governed by the C<utf8> flag. If it is disabled, this allows you
  to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
  Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
  
  So neither C<latin1>, C<binary> nor C<ascii> are incompatible with the
  C<utf8> flag - they only govern when the JSON output engine escapes a
  character or not.
  
  The main use for C<latin1> or C<binary> is to relatively efficiently
  store binary data as JSON, at the expense of breaking compatibility
  with most JSON decoders.
  
  The main use for C<ascii> is to force the output to not contain characters
  with values > 127, which means you can interpret the resulting string
  as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
  8-bit-encoding, and still get the same data structure back. This is useful
  when your channel for JSON transfer is not 8-bit clean or the encoding
  might be mangled in between (e.g. in mail), and works because ASCII is a
  proper subset of most 8-bit and multibyte encodings in use in the world.
  
  =back
  
  
  =head2 JSON and ECMAscript
  
  JSON syntax is based on how literals are represented in javascript (the
  not-standardised predecessor of ECMAscript) which is presumably why it is
  called "JavaScript Object Notation".
  
  However, JSON is not a subset (and also not a superset of course) of
  ECMAscript (the standard) or javascript (whatever browsers actually
  implement).
  
  If you want to use javascript's C<eval> function to "parse" JSON, you
  might run into parse errors for valid JSON texts, or the resulting data
  structure might not be queryable:
  
  One of the problems is that U+2028 and U+2029 are valid characters inside
  JSON strings, but are not allowed in ECMAscript string literals, so the
  following Perl fragment will not output something that can be guaranteed
  to be parsable by javascript's C<eval>:
  
     use Cpanel::JSON::XS;
  
     print encode_json [chr 0x2028];
  
  The right fix for this is to use a proper JSON parser in your javascript
  programs, and not rely on C<eval> (see for example Douglas Crockford's
  F<json2.js> parser).
  
  If this is not an option, you can, as a stop-gap measure, simply encode to
  ASCII-only JSON:
  
     use Cpanel::JSON::XS;
  
     print Cpanel::JSON::XS->new->ascii->encode ([chr 0x2028]);
  
  Note that this will enlarge the resulting JSON text quite a bit if you
  have many non-ASCII characters. You might be tempted to run some regexes
  to only escape U+2028 and U+2029, e.g.:
  
     # DO NOT USE THIS!
     my $json = Cpanel::JSON::XS->new->utf8->encode ([chr 0x2028]);
     $json =~ s/\xe2\x80\xa8/\\u2028/g; # escape U+2028
     $json =~ s/\xe2\x80\xa9/\\u2029/g; # escape U+2029
     print $json;
  
  Note that I<this is a bad idea>: the above only works for U+2028 and
  U+2029 and thus only for fully ECMAscript-compliant parsers. Many existing
  javascript implementations, however, have issues with other characters as
  well - using C<eval> naively simply I<will> cause problems.
  
  Another problem is that some javascript implementations reserve
  some property names for their own purposes (which probably makes
  them non-ECMAscript-compliant). For example, Iceweasel reserves the
  C<__proto__> property name for its own purposes.
  
  If that is a problem, you could parse try to filter the resulting JSON
  output for these property strings, e.g.:
  
     $json =~ s/"__proto__"\s*:/"__proto__renamed":/g;
  
  This works because C<__proto__> is not valid outside of strings, so every
  occurence of C<"__proto__"\s*:> must be a string used as property name.
  
  If you know of other incompatibilities, please let me know.
  
  
  =head2 JSON and YAML
  
  You often hear that JSON is a subset of YAML. This is, however, a mass
  hysteria(*) and very far from the truth (as of the time of this writing),
  so let me state it clearly: I<in general, there is no way to configure
  JSON::XS to output a data structure as valid YAML> that works in all
  cases.
  
  If you really must use Cpanel::JSON::XS to generate YAML, you should use this
  algorithm (subject to change in future versions):
  
     my $to_yaml = Cpanel::JSON::XS->new->utf8->space_after (1);
     my $yaml = $to_yaml->encode ($ref) . "\n";
  
  This will I<usually> generate JSON texts that also parse as valid
  YAML. Please note that YAML has hardcoded limits on (simple) object key
  lengths that JSON doesn't have and also has different and incompatible
  unicode character escape syntax, so you should make sure that your hash
  keys are noticeably shorter than the 1024 "stream characters" YAML allows
  and that you do not have characters with codepoint values outside the
  Unicode BMP (basic multilingual page). YAML also does not allow C<\/>
  sequences in strings (which Cpanel::JSON::XS does not I<currently> generate, but
  other JSON generators might).
  
  There might be other incompatibilities that I am not aware of (or the YAML
  specification has been changed yet again - it does so quite often). In
  general you should not try to generate YAML with a JSON generator or vice
  versa, or try to parse JSON with a YAML parser or vice versa: chances are
  high that you will run into severe interoperability problems when you
  least expect it.
  
  =over 4
  
  =item (*)
  
  I have been pressured multiple times by Brian Ingerson (one of the
  authors of the YAML specification) to remove this paragraph, despite him
  acknowledging that the actual incompatibilities exist. As I was personally
  bitten by this "JSON is YAML" lie, I refused and said I will continue to
  educate people about these issues, so others do not run into the same
  problem again and again. After this, Brian called me a (quote)I<complete
  and worthless idiot>(unquote).
  
  In my opinion, instead of pressuring and insulting people who actually
  clarify issues with YAML and the wrong statements of some of its
  proponents, I would kindly suggest reading the JSON spec (which is not
  that difficult or long) and finally make YAML compatible to it, and
  educating users about the changes, instead of spreading lies about the
  real compatibility for many I<years> and trying to silence people who
  point out that it isn't true.
  
  Addendum/2009: the YAML 1.2 spec is still incompatible with JSON, even
  though the incompatibilities have been documented (and are known to Brian)
  for many years and the spec makes explicit claims that YAML is a superset
  of JSON. It would be so easy to fix, but apparently, bullying people and
  corrupting userdata is so much easier.
  
  =back
  
  
  =head2 SPEED
  
  It seems that JSON::XS is surprisingly fast, as shown in the following
  tables. They have been generated with the help of the C<eg/bench> program
  in the JSON::XS distribution, to make it easy to compare on your own
  system.
  
  JSON::XS is with L<Data::MessagePack> one of the fastest serializers,
  because JSON and JSON::XS do not support backrefs (no graph structures),
  only trees. Storable supports backrefs, i.e. graphs. Data::MessagePack
  encodes its data binary (as Storable) and supports only very simple
  subset of JSON.
  
  First comes a comparison between various modules using
  a very short single-line JSON string (also available at
  L<http://dist.schmorp.de/misc/json/short.json>).
  
     {"method": "handleMessage", "params": ["user1",
     "we were just talking"], "id": null, "array":[1,11,234,-5,1e5,1e7,
     1,  0]}
  
  It shows the number of encodes/decodes per second (JSON::XS uses
  the functional interface, while Cpanel::JSON::XS/2 uses the OO interface
  with pretty-printing and hashkey sorting enabled, Cpanel::JSON::XS/3 enables
  shrink. JSON::DWIW/DS uses the deserialise function, while JSON::DWIW::FJ
  uses the from_json method). Higher is better:
  
     module        |     encode |     decode |
     --------------|------------|------------|
     JSON::DWIW/DS |  86302.551 | 102300.098 |
     JSON::DWIW/FJ |  86302.551 |  75983.768 |
     JSON::PP      |  15827.562 |   6638.658 |
     JSON::Syck    |  63358.066 |  47662.545 |
     JSON::XS      | 511500.488 | 511500.488 |
     JSON::XS/2    | 291271.111 | 388361.481 |
     JSON::XS/3    | 361577.931 | 361577.931 |
     Storable      |  66788.280 | 265462.278 |
     --------------+------------+------------+
  
  That is, JSON::XS is almost six times faster than JSON::DWIW on encoding,
  about five times faster on decoding, and over thirty to seventy times
  faster than JSON's pure perl implementation. It also compares favourably
  to Storable for small amounts of data.
  
  Using a longer test string (roughly 18KB, generated from Yahoo! Locals
  search API (L<http://dist.schmorp.de/misc/json/long.json>).
  
     module        |     encode |     decode |
     --------------|------------|------------|
     JSON::DWIW/DS |   1647.927 |   2673.916 |
     JSON::DWIW/FJ |   1630.249 |   2596.128 |
     JSON::PP      |    400.640 |     62.311 |
     JSON::Syck    |   1481.040 |   1524.869 |
     JSON::XS      |  20661.596 |   9541.183 |
     JSON::XS/2    |  10683.403 |   9416.938 |
     JSON::XS/3    |  20661.596 |   9400.054 |
     Storable      |  19765.806 |  10000.725 |
     --------------+------------+------------+
  
  Again, JSON::XS leads by far (except for Storable which non-surprisingly
  decodes a bit faster).
  
  On large strings containing lots of high Unicode characters, some modules
  (such as JSON::PC) seem to decode faster than JSON::XS, but the result
  will be broken due to missing (or wrong) Unicode handling. Others refuse
  to decode or encode properly, so it was impossible to prepare a fair
  comparison table for that case.
  
  
  =head1 SECURITY CONSIDERATIONS
  
  When you are using JSON in a protocol, talking to untrusted potentially
  hostile creatures requires relatively few measures.
  
  First of all, your JSON decoder should be secure, that is, should not have
  any buffer overflows. Obviously, this module should ensure that and I am
  trying hard on making that true, but you never know.
  
  Second, you need to avoid resource-starving attacks. That means you should
  limit the size of JSON texts you accept, or make sure then when your
  resources run out, that's just fine (e.g. by using a separate process that
  can crash safely). The size of a JSON text in octets or characters is
  usually a good indication of the size of the resources required to decode
  it into a Perl structure. While JSON::XS can check the size of the JSON
  text, it might be too late when you already have it in memory, so you
  might want to check the size before you accept the string.
  
  Third, JSON::XS recurses using the C stack when decoding objects and
  arrays. The C stack is a limited resource: for instance, on my amd64
  machine with 8MB of stack size I can decode around 180k nested arrays but
  only 14k nested JSON objects (due to perl itself recursing deeply on croak
  to free the temporary). If that is exceeded, the program crashes. To be
  conservative, the default nesting limit is set to 512. If your process
  has a smaller stack, you should adjust this setting accordingly with the
  C<max_depth> method.
  
  Something else could bomb you, too, that I forgot to think of. In that
  case, you get to keep the pieces. I am always open for hints, though...
  
  Also keep in mind that JSON::XS might leak contents of your Perl data
  structures in its error messages, so when you serialise sensitive
  information you might want to make sure that exceptions thrown by JSON::XS
  will not end up in front of untrusted eyes.
  
  If you are using JSON::XS to return packets to consumption
  by JavaScript scripts in a browser you should have a look at
  L<http://blog.archive.jpsykes.com/47/practical-csrf-and-json-security/> to
  see whether you are vulnerable to some common attack vectors (which really
  are browser design bugs, but it is still you who will have to deal with
  it, as major browser developers care only for features, not about getting
  security right).
  
  
  =head1 THREADS
  
  This module is I<not> guaranteed to be thread safe and there are no
  plans to change this until Perl gets thread support (as opposed to the
  horribly slow so-called "threads" which are simply slow and bloated
  process simulations - use fork, it's I<much> faster, cheaper, better).
  
  (It might actually work, but you have been warned).
  
  L<Data::MessagePack> in comparison is thread-safe.
  
  =head1 BUGS
  
  While the goal of the JSON::XS module is to be correct, that
  unfortunately does not mean it's bug-free, only that the author thinks
  its design is bug-free. If you keep reporting bugs they will be fixed
  swiftly, though.
  
  Since the JSON::XS author refuses to use a public bugtracker and
  prefers private emails, we've setup a tracker at RT, so you might want
  to report any issues twice. Once in private to MLEHMANN to be fixed in
  JSON::XS for the masses and one to our the public tracker. Issues
  fixed by JSON::XS with a new release will also be backported to
  Cpanel::JSON::XS and 5.6.2, as long as Cpanel relies on 5.6.2 and
  JSON::XS as our serializer of choice.
  
  L<https://rt.cpan.org/Public/Dist/Display.html?Queue=Cpanel-JSON-XS>
  
  =cut
  
  our $true  = do { bless \(my $dummy = 1), "Cpanel::JSON::XS::Boolean" };
  our $false = do { bless \(my $dummy = 0), "Cpanel::JSON::XS::Boolean" };
  
  sub true()  { $true  }
  sub false() { $false }
  
  sub is_bool($) {
     UNIVERSAL::isa $_[0], "Cpanel::JSON::XS::Boolean"
  #      or UNIVERSAL::isa $_[0], "JSON::Literal"
  }
  
  XSLoader::load 'Cpanel::JSON::XS', $VERSION;
  
  package Cpanel::JSON::XS::Boolean;
  
  use overload
     "0+"     => sub { ${$_[0]} },
     "++"     => sub { $_[0] = ${$_[0]} + 1 },
     "--"     => sub { $_[0] = ${$_[0]} - 1 },
    '""'      => sub { ${$_[0]} == 1 ? 'true' : 'false' },
    'eq'      => sub {
      my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
      if ($op eq 'true' or $op eq 'false') {
        return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
      }
      else {
        return $obj ? 1 == $op : 0 == $op;
      }
     },
     fallback => 1;
  
  1;
  
  =head1 SEE ALSO
  
  The F<cpanel_json_xs> command line utility for quick experiments.
  
  =head1 AUTHOR
  
    Marc Lehmann <schmorp@schmorp.de>
    http://home.schmorp.de/
  
  =head1 MAINTAINER
  
    cPanel Inc. <cpan@cpanel.net>
  
  =cut
  
X86_64-LINUX_CPANEL_JSON_XS

$fatpacked{"x86_64-linux/Cpanel/JSON/XS/Boolean.pm"} = <<'X86_64-LINUX_CPANEL_JSON_XS_BOOLEAN';
  =head1 NAME
  
  Cpanel::JSON::XS::Boolean - dummy module providing Cpanel::JSON::XS::Boolean
  
  =head1 SYNOPSIS
  
   # do not "use" yourself
  
  =head1 DESCRIPTION
  
  This module exists only to provide overload resolution for Storable and similar modules. See
  L<Cpanel::JSON::XS> for more info about this class.
  
  =cut
  
  use Cpanel::JSON::XS ();
  
  1;
  
  =head1 AUTHOR
  
   Marc Lehmann <schmorp@schmorp.de>
   http://home.schmorp.de/
  
  =cut
  
X86_64-LINUX_CPANEL_JSON_XS_BOOLEAN

$fatpacked{"x86_64-linux/Package/Stash/XS.pm"} = <<'X86_64-LINUX_PACKAGE_STASH_XS';
  package Package::Stash::XS;
  BEGIN {
    $Package::Stash::XS::AUTHORITY = 'cpan:DOY';
  }
  {
    $Package::Stash::XS::VERSION = '0.26';
  }
  use strict;
  use warnings;
  use 5.008001;
  # ABSTRACT: faster and more correct implementation of the Package::Stash API
  
  use XSLoader;
  XSLoader::load(
      __PACKAGE__,
      # we need to be careful not to touch $VERSION at compile time, otherwise
      # DynaLoader will assume it's set and check against it, which will cause
      # fail when being run in the checkout without dzil having set the actual
      # $VERSION
      exists $Package::Stash::XS::{VERSION}
          ? ${ $Package::Stash::XS::{VERSION} } : (),
  );
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Package::Stash::XS - faster and more correct implementation of the Package::Stash API
  
  =head1 VERSION
  
  version 0.26
  
  =head1 SYNOPSIS
  
    use Package::Stash;
  
  =head1 DESCRIPTION
  
  This is a backend for L<Package::Stash>, which provides the functionality in a
  way that's less buggy and much faster. It will be used by default if it's
  installed, and should be preferred in all environments with a compiler.
  
  =head1 BUGS
  
  No known bugs (but see the BUGS section in L<Package::Stash>).
  
  Please report any bugs through RT: email
  C<bug-package-stash-xs at rt.cpan.org>, or browse to
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash-XS>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Class::MOP::Package>
  
  This module is a factoring out of code that used to live here
  
  =back
  
  =head1 SUPPORT
  
  You can find this documentation for this module with the perldoc command.
  
      perldoc Package::Stash::XS
  
  You can also look for information at:
  
  =over 4
  
  =item * AnnoCPAN: Annotated CPAN documentation
  
  L<http://annocpan.org/dist/Package-Stash-XS>
  
  =item * CPAN Ratings
  
  L<http://cpanratings.perl.org/d/Package-Stash-XS>
  
  =item * RT: CPAN's request tracker
  
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash-XS>
  
  =item * Search CPAN
  
  L<http://search.cpan.org/dist/Package-Stash-XS>
  
  =back
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy at tozt dot net>
  
  Based on code from L<Class::MOP::Package>, by Stevan Little and the Moose
  Cabal.
  
  =for Pod::Coverage add_symbol
  get_all_symbols
  get_or_add_symbol
  get_symbol
  has_symbol
  list_all_symbols
  name
  namespace
  new
  remove_glob
  remove_symbol
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy at tozt dot net>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2013 by Jesse Luehrs.
  
  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
X86_64-LINUX_PACKAGE_STASH_XS

$fatpacked{"x86_64-linux/Sub/Name.pm"} = <<'X86_64-LINUX_SUB_NAME';
  package Sub::Name;
  
  =head1 NAME
  
  Sub::Name - (re)name a sub
  
  =head1 SYNOPSIS
  
      use Sub::Name;
  
      subname $name, $subref;
  
      $subref = subname foo => sub { ... };
  
  =head1 DESCRIPTION
  
  This module has only one function, which is also exported by default:
  
  =head2 subname NAME, CODEREF
  
  Assigns a new name to referenced sub.  If package specification is omitted in 
  the name, then the current package is used.  The return value is the sub.
  
  The name is only used for informative routines (caller, Carp, etc).  You won't 
  be able to actually invoke the sub by the given name.  To allow that, you need 
  to do glob-assignment yourself.
  
  Note that for anonymous closures (subs that reference lexicals declared outside 
  the sub itself) you can name each instance of the closure differently, which 
  can be very useful for debugging.
  
  =head1 AUTHOR
  
  Matthijs van Duin <xmath@cpan.org>
  
  Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
  This program is free software; you can redistribute it and/or modify 
  it under the same terms as Perl itself.
  
  =cut
  
  use 5.006;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.05';
  
  use base 'Exporter';
  use base 'DynaLoader';
  
  our @EXPORT = qw(subname);
  our @EXPORT_OK = @EXPORT;
  
  bootstrap Sub::Name $VERSION;
  
  1;
X86_64-LINUX_SUB_NAME

$fatpacked{"x86_64-linux/Variable/Magic.pm"} = <<'X86_64-LINUX_VARIABLE_MAGIC';
  package Variable::Magic;
  
  use 5.008;
  
  use strict;
  use warnings;
  
  =head1 NAME
  
  Variable::Magic - Associate user-defined magic to variables from Perl.
  
  =head1 VERSION
  
  Version 0.52
  
  =cut
  
  our $VERSION;
  BEGIN {
   $VERSION = '0.52';
  }
  
  =head1 SYNOPSIS
  
      use Variable::Magic qw<wizard cast VMG_OP_INFO_NAME>;
  
      { # A variable tracer
       my $wiz = wizard(
        set  => sub { print "now set to ${$_[0]}!\n" },
        free => sub { print "destroyed!\n" },
       );
  
       my $a = 1;
       cast $a, $wiz;
       $a = 2;        # "now set to 2!"
      }               # "destroyed!"
  
      { # A hash with a default value
       my $wiz = wizard(
        data     => sub { $_[1] },
        fetch    => sub { $_[2] = $_[1] unless exists $_[0]->{$_[2]}; () },
        store    => sub { print "key $_[2] stored in $_[-1]\n" },
        copy_key => 1,
        op_info  => VMG_OP_INFO_NAME,
       );
  
       my %h = (_default => 0, apple => 2);
       cast %h, $wiz, '_default';
       print $h{banana}, "\n"; # "0" (there is no 'banana' key in %h)
       $h{pear} = 1;           # "key pear stored in helem"
      }
  
  =head1 DESCRIPTION
  
  Magic is Perl's way of enhancing variables.
  This mechanism lets the user add extra data to any variable and hook syntactical operations (such as access, assignment or destruction) that can be applied to it.
  With this module, you can add your own magic to any variable without having to write a single line of XS.
  
  You'll realize that these magic variables look a lot like tied variables.
  It is not surprising, as tied variables are implemented as a special kind of magic, just like any 'irregular' Perl variable : scalars like C<$!>, C<$(> or C<$^W>, the C<%ENV> and C<%SIG> hashes, the C<@ISA> array,  C<vec()> and C<substr()> lvalues, L<threads::shared> variables...
  They all share the same underlying C API, and this module gives you direct access to it.
  
  Still, the magic made available by this module differs from tieing and overloading in several ways :
  
  =over 4
  
  =item *
  
  Magic is not copied on assignment.
  
  You attach it to variables, not values (as for blessed references).
  
  =item *
  
  Magic does not replace the original semantics.
  
  Magic callbacks usually get triggered before the original action takes place, and cannot prevent it from happening.
  This also makes catching individual events easier than with C<tie>, where you have to provide fallbacks methods for all actions by usually inheriting from the correct C<Tie::Std*> class and overriding individual methods in your own class.
  
  =item *
  
  Magic is multivalued.
  
  You can safely apply different kinds of magics to the same variable, and each of them will be invoked successively.
  
  =item *
  
  Magic is type-agnostic.
  
  The same magic can be applied on scalars, arrays, hashes, subs or globs.
  But the same hook (see below for a list) may trigger differently depending on the the type of the variable.
  
  =item *
  
  Magic is invisible at Perl level.
  
  Magical and non-magical variables cannot be distinguished with C<ref>, C<tied> or another trick.
  
  =item *
  
  Magic is notably faster.
  
  Mainly because perl's way of handling magic is lighter by nature, and because there is no need for any method resolution.
  Also, since you don't have to reimplement all the variable semantics, you only pay for what you actually use.
  
  =back
  
  The operations that can be overloaded are :
  
  =over 4
  
  =item *
  
  I<get>
  
  This magic is invoked when the variable is evaluated.
  It is never called for arrays and hashes.
  
  =item *
  
  I<set>
  
  This magic is called each time the value of the variable changes.
  It is called for array subscripts and slices, but never for hashes.
  
  =item *
  
  I<len>
  
  This magic only applies to arrays (though it used to also apply to scalars), and is triggered when the 'size' or the 'length' of the variable has to be known by Perl.
  This is typically the magic involved when an array is evaluated in scalar context, but also on array assignment and loops (C<for>, C<map> or C<grep>).
  The length is returned from the callback as an integer.
  
  Starting from perl 5.12, this magic is no longer called by the C<length> keyword, and starting from perl 5.17.4 it is also no longer called for scalars in any situation, making this magic only meaningful on arrays.
  You can use the constants L</VMG_COMPAT_SCALAR_LENGTH_NOLEN> and L</VMG_COMPAT_SCALAR_NOLEN> to see if this magic is available for scalars or not.
  
  =item *
  
  I<clear>
  
  This magic is invoked when the variable is reset, such as when an array is emptied.
  Please note that this is different from undefining the variable, even though the magic is called when the clearing is a result of the undefine (e.g. for an array, but actually a bug prevent it to work before perl 5.9.5 - see the L<history|/PERL MAGIC HISTORY>).
  
  =item *
  
  I<free>
  
  This magic is called when a variable is destroyed as the result of going out of scope (but not when it is undefined).
  It behaves roughly like Perl object destructors (i.e. C<DESTROY> methods), except that exceptions thrown from inside a I<free> callback will always be propagated to the surrounding code.
  
  =item *
  
  I<copy>
  
  This magic only applies to tied arrays and hashes, and fires when you try to access or change their elements.
  
  =item *
  
  I<dup>
  
  This magic is invoked when the variable is cloned across threads.
  It is currently not available.
  
  =item *
  
  I<local>
  
  When this magic is set on a variable, all subsequent localizations of the variable will trigger the callback.
  It is available on your perl if and only if C<MGf_LOCAL> is true.
  
  =back
  
  The following actions only apply to hashes and are available if and only if L</VMG_UVAR> is true.
  They are referred to as I<uvar> magics.
  
  =over 4
  
  =item *
  
  I<fetch>
  
  This magic is invoked each time an element is fetched from the hash.
  
  =item *
  
  I<store>
  
  This one is called when an element is stored into the hash.
  
  =item *
  
  I<exists>
  
  This magic fires when a key is tested for existence in the hash.
  
  =item *
  
  I<delete>
  
  This magic is triggered when a key is deleted in the hash, regardless of whether the key actually exists in it.
  
  =back
  
  You can refer to the tests to have more insight of where the different magics are invoked.
  
  =head1 FUNCTIONS
  
  =cut
  
  BEGIN {
   require XSLoader;
   XSLoader::load(__PACKAGE__, $VERSION);
  }
  
  =head2 C<wizard>
  
      wizard(
       data     => sub { ... },
       get      => sub { my ($ref, $data [, $op]) = @_; ... },
       set      => sub { my ($ref, $data [, $op]) = @_; ... },
       len      => sub {
        my ($ref, $data, $len [, $op]) = @_; ... ; return $newlen
       },
       clear    => sub { my ($ref, $data [, $op]) = @_; ... },
       free     => sub { my ($ref, $data [, $op]) = @_, ... },
       copy     => sub { my ($ref, $data, $key, $elt [, $op]) = @_; ... },
       local    => sub { my ($ref, $data [, $op]) = @_; ... },
       fetch    => sub { my ($ref, $data, $key [, $op]) = @_; ... },
       store    => sub { my ($ref, $data, $key [, $op]) = @_; ... },
       exists   => sub { my ($ref, $data, $key [, $op]) = @_; ... },
       delete   => sub { my ($ref, $data, $key [, $op]) = @_; ... },
       copy_key => $bool,
       op_info  => [ 0 | VMG_OP_INFO_NAME | VMG_OP_INFO_OBJECT ],
      )
  
  This function creates a 'wizard', an opaque object that holds the magic information.
  It takes a list of keys / values as argument, whose keys can be :
  
  =over 4
  
  =item *
  
  C<data>
  
  A code (or string) reference to a private data constructor.
  It is called in scalar context each time the magic is cast onto a variable, with C<$_[0]> being a reference to this variable and C<@_[1 .. @_-1]> being all extra arguments that were passed to L</cast>.
  The scalar returned from this call is then attached to the variable and can be retrieved later with L</getdata>.
  
  =item *
  
  C<get>, C<set>, C<len>, C<clear>, C<free>, C<copy>, C<local>, C<fetch>, C<store>, C<exists> and C<delete>
  
  Code (or string) references to the respective magic callbacks.
  You don't have to specify all of them : the magic corresponding to undefined entries will simply not be hooked.
  
  When those callbacks are executed, C<$_[0]> is a reference to the magic variable and C<$_[1]> is the associated private data (or C<undef> when no private data constructor is supplied with the wizard).
  Other arguments depend on which kind of magic is involved :
  
  =over 8
  
  =item *
  
  I<len>
  
  C<$_[2]> contains the natural, non-magical length of the variable (which can only be a scalar or an array as I<len> magic is only relevant for these types).
  The callback is expected to return the new scalar or array length to use, or C<undef> to default to the normal length.
  
  =item *
  
  I<copy>
  
  C<$_[2]> is a either an alias or a copy of the current key, and C<$_[3]> is an alias to the current element (i.e. the value).
  Because C<$_[2]> might be a copy, it is useless to try to change it or cast magic on it.
  
  =item *
  
  I<fetch>, I<store>, I<exists> and I<delete>
  
  C<$_[2]> is an alias to the current key.
  Note that C<$_[2]> may rightfully be readonly if the key comes from a bareword, and as such it is unsafe to assign to it.
  You can ask for a copy instead by passing C<< copy_key => 1 >> to L</wizard> which, at the price of a small performance hit, allows you to safely assign to C<$_[2]> in order to e.g. redirect the action to another key.
  
  =back
  
  Finally, if C<< op_info => $num >> is also passed to C<wizard>, then one extra element is appended to C<@_>.
  Its nature depends on the value of C<$num> :
  
  =over 8
  
  =item *
  
  C<VMG_OP_INFO_NAME>
  
  C<$_[-1]> is the current op name.
  
  =item *
  
  C<VMG_OP_INFO_OBJECT>
  
  C<$_[-1]> is the C<B::OP> object for the current op.
  
  =back
  
  Both result in a small performance hit, but just getting the name is lighter than getting the op object.
  
  These callbacks are executed in scalar context and are expected to return an integer, which is then passed straight to the perl magic API.
  However, only the return value of the I<len> magic callback currently holds a meaning.
  
  =back
  
  Each callback can be specified as :
  
  =over 4
  
  =item *
  
  a code reference, which will be called as a subroutine.
  
  =item *
  
  a string reference, where the string denotes which subroutine is to be called when magic is triggered.
  If the subroutine name is not fully qualified, then the current package at the time the magic is invoked will be used instead.
  
  =item *
  
  a reference to C<undef>, in which case a no-op magic callback is installed instead of the default one.
  This may especially be helpful for I<local> magic, where an empty callback prevents magic from being copied during localization.
  
  =back
  
  Note that I<free> magic is never called during global destruction, as there is no way to ensure that the wizard object and the callback were not destroyed before the variable.
  
  Here is a simple usage example :
  
      # A simple scalar tracer
      my $wiz = wizard(
       get  => sub { print STDERR "got ${$_[0]}\n" },
       set  => sub { print STDERR "set to ${$_[0]}\n" },
       free => sub { print STDERR "${$_[0]} was deleted\n" },
      );
  
  =cut
  
  sub wizard {
   if (@_ % 2) {
    require Carp;
    Carp::croak('Wrong number of arguments for wizard()');
   }
  
   my %opts = @_;
  
   my @keys = qw<op_info data get set len clear free copy dup>;
   push @keys, 'local' if MGf_LOCAL;
   push @keys, qw<fetch store exists delete copy_key> if VMG_UVAR;
  
   my ($wiz, $err);
   {
    local $@;
    $wiz = eval { _wizard(map $opts{$_}, @keys) };
    $err = $@;
   }
   if ($err) {
    $err =~ s/\sat\s+.*?\n//;
    require Carp;
    Carp::croak($err);
   }
  
   return $wiz;
  }
  
  =head2 C<cast>
  
      cast [$@%&*]var, $wiz, @args
  
  This function associates C<$wiz> magic to the supplied variable, without overwriting any other kind of magic.
  It returns true on success or when C<$wiz> magic is already attached, and croaks on error.
  When C<$wiz> provides a data constructor, it is called just before magic is cast onto the variable, and it receives a reference to the target variable in C<$_[0]> and the content of C<@args> in C<@_[1 .. @args]>.
  Otherwise, C<@args> is ignored.
  
      # Casts $wiz onto $x, passing (\$x, '1') to the data constructor.
      my $x;
      cast $x, $wiz, 1;
  
  The C<var> argument can be an array or hash value.
  Magic for these scalars behaves like for any other, except that it is dispelled when the entry is deleted from the container.
  For example, if you want to call C<POSIX::tzset> each time the C<'TZ'> environment variable is changed in C<%ENV>, you can use :
  
      use POSIX;
      cast $ENV{TZ}, wizard set => sub { POSIX::tzset(); () };
  
  If you want to handle the possible deletion of the C<'TZ'> entry, you must also specify I<store> magic.
  
  =head2 C<getdata>
  
      getdata [$@%&*]var, $wiz
  
  This accessor fetches the private data associated with the magic C<$wiz> in the variable.
  It croaks when C<$wiz> does not represent a valid magic object, and returns an empty list if no such magic is attached to the variable or when the wizard has no data constructor.
  
      # Get the data attached to $wiz in $x, or undef if $wiz
      # did not attach any.
      my $data = getdata $x, $wiz;
  
  =head2 C<dispell>
  
      dispell [$@%&*]variable, $wiz
  
  The exact opposite of L</cast> : it dissociates C<$wiz> magic from the variable.
  This function returns true on success, C<0> when no magic represented by C<$wiz> could be found in the variable, and croaks if the supplied wizard is invalid.
  
      # Dispell now.
      die 'no such magic in $x' unless dispell $x, $wiz;
  
  =head1 CONSTANTS
  
  =head2 C<MGf_COPY>
  
  Evaluates to true if and only if the I<copy> magic is available.
  This is the case for perl 5.7.3 and greater, which is ensured by the requirements of this module.
  
  =head2 C<MGf_DUP>
  
  Evaluates to true if and only if the I<dup> magic is available.
  This is the case for perl 5.7.3 and greater, which is ensured by the requirements of this module.
  
  =head2 C<MGf_LOCAL>
  
  Evaluates to true if and only if the I<local> magic is available.
  This is the case for perl 5.9.3 and greater.
  
  =head2 C<VMG_UVAR>
  
  When this constant is true, you can use the I<fetch>, I<store>, I<exists> and I<delete> magics on hashes.
  Initial L</VMG_UVAR> capability was introduced in perl 5.9.5, with a fully functional implementation shipped with perl 5.10.0.
  
  =head2 C<VMG_COMPAT_SCALAR_LENGTH_NOLEN>
  
  True for perls that don't call I<len> magic when taking the C<length> of a magical scalar.
  
  =head2 C<VMG_COMPAT_SCALAR_NOLEN>
  
  True for perls that don't call I<len> magic on scalars.
  Implies L</VMG_COMPAT_SCALAR_LENGTH_NOLEN>.
  
  =head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN>
  
  True for perls that don't call I<len> magic when you push an element in a magical array.
  Starting from perl 5.11.0, this only refers to pushes in non-void context and hence is false.
  
  =head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID>
  
  True for perls that don't call I<len> magic when you push in void context an element in a magical array.
  
  =head2 C<VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID>
  
  True for perls that don't call I<len> magic when you unshift in void context an element in a magical array.
  
  =head2 C<VMG_COMPAT_ARRAY_UNDEF_CLEAR>
  
  True for perls that call I<clear> magic when undefining magical arrays.
  
  =head2 C<VMG_COMPAT_HASH_DELETE_NOUVAR_VOID>
  
  True for perls that don't call I<delete> magic when you delete an element from a hash in void context.
  
  =head2 C<VMG_COMPAT_GLOB_GET>
  
  True for perls that call I<get> magic for operations on globs.
  
  =head2 C<VMG_PERL_PATCHLEVEL>
  
  The perl patchlevel this module was built with, or C<0> for non-debugging perls.
  
  =head2 C<VMG_THREADSAFE>
  
  True if and only if this module could have been built with thread-safety features enabled.
  
  =head2 C<VMG_FORKSAFE>
  
  True if and only if this module could have been built with fork-safety features enabled.
  This is always true except on Windows where it is false for perl 5.10.0 and below.
  
  =head2 C<VMG_OP_INFO_NAME>
  
  Value to pass with C<op_info> to get the current op name in the magic callbacks.
  
  =head2 C<VMG_OP_INFO_OBJECT>
  
  Value to pass with C<op_info> to get a C<B::OP> object representing the current op in the magic callbacks.
  
  =head1 COOKBOOK
  
  =head2 Associate an object to any perl variable
  
  This technique can be useful for passing user data through limited APIs.
  It is similar to using inside-out objects, but without the drawback of having to implement a complex destructor.
  
      {
       package Magical::UserData;
  
       use Variable::Magic qw<wizard cast getdata>;
  
       my $wiz = wizard data => sub { \$_[1] };
  
       sub ud (\[$@%*&]) : lvalue {
        my ($var) = @_;
        my $data = &getdata($var, $wiz);
        unless (defined $data) {
         $data = \(my $slot);
         &cast($var, $wiz, $slot)
                   or die "Couldn't cast UserData magic onto the variable";
        }
        $$data;
       }
      }
  
      {
       BEGIN { *ud = \&Magical::UserData::ud }
  
       my $cb;
       $cb = sub { print 'Hello, ', ud(&$cb), "!\n" };
  
       ud(&$cb) = 'world';
       $cb->(); # Hello, world!
      }
  
  =head2 Recursively cast magic on datastructures
  
  C<cast> can be called from any magical callback, and in particular from C<data>.
  This allows you to recursively cast magic on datastructures :
  
      my $wiz;
      $wiz = wizard data => sub {
       my ($var, $depth) = @_;
       $depth ||= 0;
       my $r = ref $var;
       if ($r eq 'ARRAY') {
        &cast((ref() ? $_ : \$_), $wiz, $depth + 1) for @$var;
       } elsif ($r eq 'HASH') {
        &cast((ref() ? $_ : \$_), $wiz, $depth + 1) for values %$var;
       }
       return $depth;
      },
      free => sub {
       my ($var, $depth) = @_;
       my $r = ref $var;
       print "free $r at depth $depth\n";
       ();
      };
  
      {
       my %h = (
        a => [ 1, 2 ],
        b => { c => 3 }
       );
       cast %h, $wiz;
      }
  
  When C<%h> goes out of scope, this prints something among the lines of :
  
      free HASH at depth 0
      free HASH at depth 1
      free SCALAR at depth 2
      free ARRAY at depth 1
      free SCALAR at depth 3
      free SCALAR at depth 3
  
  Of course, this example does nothing with the values that are added after the C<cast>.
  
  =head1 PERL MAGIC HISTORY
  
  The places where magic is invoked have changed a bit through perl history.
  Here is a little list of the most recent ones.
  
  =over 4
  
  =item *
  
  B<5.6.x>
  
  I<p14416> : I<copy> and I<dup> magic.
  
  =item *
  
  B<5.8.9>
  
  I<p28160> : Integration of I<p25854> (see below).
  
  I<p32542> : Integration of I<p31473> (see below).
  
  =item *
  
  B<5.9.3>
  
  I<p25854> : I<len> magic is no longer called when pushing an element into a magic array.
  
  I<p26569> : I<local> magic.
  
  =item *
  
  B<5.9.5>
  
  I<p31064> : Meaningful I<uvar> magic.
  
  I<p31473> : I<clear> magic was not invoked when undefining an array.
  The bug is fixed as of this version.
  
  =item *
  
  B<5.10.0>
  
  Since C<PERL_MAGIC_uvar> is uppercased, C<hv_magic_check()> triggers I<copy> magic on hash stores for (non-tied) hashes that also have I<uvar> magic.
  
  =item *
  
  B<5.11.x>
  
  I<p32969> : I<len> magic is no longer invoked when calling C<length> with a magical scalar.
  
  I<p34908> : I<len> magic is no longer called when pushing / unshifting an element into a magical array in void context.
  The C<push> part was already covered by I<p25854>.
  
  I<g9cdcb38b> : I<len> magic is called again when pushing into a magical array in non-void context.
  
  =back
  
  =head1 EXPORT
  
  The functions L</wizard>, L</cast>, L</getdata> and L</dispell> are only exported on request.
  All of them are exported by the tags C<':funcs'> and C<':all'>.
  
  All the constants are also only exported on request, either individually or by the tags C<':consts'> and C<':all'>.
  
  =cut
  
  use base qw<Exporter>;
  
  our @EXPORT         = ();
  our %EXPORT_TAGS    = (
   'funcs' =>  [ qw<wizard cast getdata dispell> ],
   'consts' => [ qw<
     MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR
     VMG_COMPAT_SCALAR_LENGTH_NOLEN
     VMG_COMPAT_SCALAR_NOLEN
     VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
     VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
     VMG_COMPAT_ARRAY_UNDEF_CLEAR
     VMG_COMPAT_HASH_DELETE_NOUVAR_VOID
     VMG_COMPAT_GLOB_GET
     VMG_PERL_PATCHLEVEL
     VMG_THREADSAFE VMG_FORKSAFE
     VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
   > ],
  );
  our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
  $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
  
  =head1 CAVEATS
  
  In order to hook hash operations with magic, you need at least perl 5.10.0 (see L</VMG_UVAR>).
  
  If you want to store a magic object in the private data slot, you will not be able to recover the magic with L</getdata>, since magic is not copied by assignment.
  You can work around this gotcha by storing a reference to the magic object instead.
  
  If you define a wizard with I<free> magic and cast it on itself, it results in a memory cycle, so this destructor will not be called when the wizard is freed.
  
  =head1 DEPENDENCIES
  
  L<perl> 5.8.
  
  A C compiler.
  This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
  
  L<Carp> (core since perl 5), L<XSLoader> (since 5.006).
  
  Copy tests need L<Tie::Array> (core since perl 5.005) and L<Tie::Hash> (since 5.002).
  Some uvar tests need L<Hash::Util::FieldHash> (since 5.009004).
  Glob tests need L<Symbol> (since 5.002).
  Threads tests need L<threads> and L<threads::shared> (both since 5.007003).
  
  =head1 SEE ALSO
  
  L<perlguts> and L<perlapi> for internal information about magic.
  
  L<perltie> and L<overload> for other ways of enhancing objects.
  
  =head1 AUTHOR
  
  Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
  
  You can contact me by mail or on C<irc.perl.org> (vincent).
  
  =head1 BUGS
  
  Please report any bugs or feature requests to C<bug-variable-magic at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Variable-Magic>.
  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
  
  =head1 SUPPORT
  
  You can find documentation for this module with the perldoc command.
  
      perldoc Variable::Magic
  
  Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Variable-Magic>.
  
  =head1 COPYRIGHT & LICENSE
  
  Copyright 2007,2008,2009,2010,2011,2012 Vincent Pit, all rights reserved.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =cut
  
  1; # End of Variable::Magic
X86_64-LINUX_VARIABLE_MAGIC

s/^  //mg for values %fatpacked;

unshift @INC, sub {
  if (my $fat = $fatpacked{$_[1]}) {
    if ($] < 5.008) {
      return sub {
        return 0 unless length $fat;
        $fat =~ s/^([^\n]*\n?)//;
        $_ = $1;
        return 1;
      };
    }
    open my $fh, '<', \$fat
      or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
    return $fh;
  }
  return
};

} # END OF FATPACK CODE

# PODNAME: installer
# ABSTRACT: Install an .installer configuration file

use strict;
use warnings;
use Getopt::Long;
use App::Installer;
use Installer::Target;
use Installer::Software;

my ( $url, $file, $installer_code );

GetOptions(
  "u=s" => \$url,
  "f=s" => \$file,
  "e=s" => \$installer_code,
);

my $target = shift @ARGV;

die "You can't give file and url at once" if defined $url and defined $file;
die "Need a target to deploy to" unless $target;

App::Installer->new(
  target => $target,
  defined $url ? ( url => $url ) : (),
  defined $file ? ( file => $file ) : (),
  defined $installer_code ? ( installer_code => $installer_code ) : (),
)->install_to_target;

=head1 SYNOPSIS

  # Directly usable without install via http://installer.pm
  curl -s -L http://installer.pm | perl - ~/myprojectenv

  # Will use .installer file in current directory
  installer ~/myprojectenv

  # Using a specific installer file
  installer -f /other/installer_file ~/myprojectenv

  # The .installer file can also be fetched by URL:
  installer -u http://stardestroyer.de/postgis.installer ~/myprojectenv

  # Giving installer code as string
  installer -e "perl '5.18.1'; cpanm 'Plack';" ~/myprojectenv

  # On shell do the following for using the environment after installation
  . ~/myprojectenv/export.sh

Sample .installer file might look like

  perl "5.18.1";
  url "http://ftp.postgresql.org/pub/source/v9.2.4/postgresql-9.2.4.tar.gz", with => {
    pgport => 15432,
  };
  url "http://download.osgeo.org/gdal/1.10.1/gdal-1.10.1.tar.gz";
  url "http://download.osgeo.org/geos/geos-3.4.2.tar.bz2";
  url "http://download.osgeo.org/postgis/source/postgis-2.1.0.tar.gz";
  cpanm "DBD::Pg";

=head1 DESCRIPTION

B<TOTALLY BETA, PLEASE TEST :D>

Bigger example for installer file options:

  url "http://host/file.tar.gz",
    with => {
      key => "value",
      other_key => undef,
    },
    enable => [qw( satan )],
    disable => [qw( god )],
    without => [qw( religion )],
    testable => 1;

Would endup with the following parameter on I<./configure>: B<--with-key=value
--with-other_key --enable-satan --disable-god --without-religion>. Also it
would run "make test" if there is a Makefile after configuration. Another
options possible (so far):

  url "http://host/file.tar.gz",
    custom_test => sub {
      $_[0]->run($_[0]->unpack_path,'testcommand','--args')
    },
    custom_configure => sub {
      $self->run($self->unpack_path,'./Configure','-des','-Dprefix='.$self->target_directory);
    },
    post_install => sub {
      $self->run(undef,'command'); # run in target directory after install
    },
    export_sh => sub {
      return "# extra lines", "# for getting added to", "# export.sh";
    };

Same options can go towards a local file:

  file "/some/local/file.tar.gz";

You can also run a custom command (it will be run inside the target directory):

  run "custom_command", "args", "args";

Install specific perl (so far no options):

  perl "5.8.8";

Or install packages via cpanm:

  cpanm qw( Yeb Dist::Zilla );

B<Be careful!> It doesn't care if you have installed a perl in the target
directory or not, and just fire up cpanm, so it would install on your local
perl installation, if you don't install perl before.

Or install packages via pip:

  pip qw( rtree imposm );

B<Be careful!> It doesn't care if you have installed pip in the target
directory or not, and just fire up pip, so it would install on your local
python environment, if you don't installed pip before.
